home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / eforth51.zip / EFORTH.ASM next >
Encoding:
Assembly Source File  |  1990-10-11  |  53.6 KB  |  2,364 lines
  1. TITLE 8051 eForth
  2.  
  3. PAGE 62,132    ;62 lines per page, 132 characters per line
  4.  
  5. ;===============================================================
  6. ;
  7. ;    8051 eForth 1.1 by C. H. Ting, 1990
  8. ;
  9. ;    This eForth system was developed using chipForth from Forth, Inc.
  10. ;    and tested on a Micromint BCC52 single board computer.
  11. ;    The eForth Model was developed by Bill Muench and C. H. Ting.
  12. ;
  13. ;    The goal of this implementation is to show that the eForth Model
  14. ;    can be ported to a ROM based 8 bit microprocessor, Intel 8051.
  15. ;    Deviations from the original eForth Model are:
  16. ;
  17. ;        All kernel words are assembled as DB statements.
  18. ;        Memory map is tailored to a ROM based system.
  19. ;        $COLON and $USER are modified to compile LJMP doLIST.
  20. ;        call, compiles a LCALL with a flipped destination address.
  21. ;        USER, VARIABLE and : are modified to use above 'call,'.
  22. ;        FORTH vocabulary pointer is a pair user variables.
  23. ;        BYE is deleted.
  24. ;
  25. ;    To assemble this source file and generate a ROM image,
  26. ;    type the following commands using MASM and LINK:
  27. ;        >MASM 8051;
  28. ;        >LINK 8051;
  29. ;    The resulting 8051.EXE contains the binary image suitable
  30. ;    for PROM programming.  The actual image is offset by 200H
  31. ;    bytes from the beginning of the .EXE file.  This image
  32. ;    must be placed in a PROM from 0 to 1FFFH, and it uses a RAM
  33. ;    chip from 8000H to 9FFFH.  If your system does not have
  34. ;    this memory configuration, modify the memory pointers in
  35. ;    the source file accordingly.  Places to be modified are
  36. ;    marked by '******'.
  37.  
  38. ;    8051 is a slow processor.  Do not expect great performance
  39. ;    of this implementation, considering that most words are in high
  40. ;    level.  Your are encouraged to recode some of the high level words
  41. ;    to optimize its performance.
  42. ;
  43. ;    Direct your questions and contributions to:
  44. ;
  45. ;        Dr. C. H. Ting
  46. ;        156 14th Avenue
  47. ;        San Mateo, CA 94402
  48. ;        (415) 571-7639
  49. ;
  50. ;===============================================================
  51.  
  52. ;; Version control
  53.  
  54. VER        EQU    01H            ;major release version
  55. EXT        EQU    01H            ;minor extension
  56.  
  57. ;; Constants
  58.  
  59. COMPO        EQU    040H            ;lexicon compile only bit
  60. IMEDD        EQU    080H            ;lexicon immediate bit
  61. MASKK        EQU    07F1FH            ;lexicon bit mask
  62.  
  63. CELLL        EQU    2            ;size of a cell
  64. BASEE        EQU    10            ;default radix
  65. VOCSS        EQU    8            ;depth of vocabulary stack
  66.  
  67. BKSPP        EQU    8            ;backspace
  68. LF        EQU    10            ;line feed
  69. CRR        EQU    13            ;carriage return
  70. ERR        EQU    27            ;error escape
  71. TIC        EQU    39            ;tick
  72.  
  73. CALLL        EQU    1200H            ;NOP CALL opcodes******
  74. LISTT        EQU    6001H            ;CALL address******
  75.  
  76. ;; Memory allocation    0//code>--//--<name//up>--<sp//tib>--rp//em
  77.  
  78. EM        EQU    0A000H            ;top of RAM memory******
  79. BM        EQU    0H            ;bottom of ROM memory******
  80. COLDD        EQU    BM+40H            ;cold start vector******
  81.  
  82. US        EQU    100H        ;user area size in cells
  83. RTS        EQU    100H        ;return stack/TIB size
  84. DTS        EQU    100H        ;data stack size
  85.  
  86. UPP        EQU    EM-US        ;start of user area (UP0)
  87. TIBB        EQU    UPP-RTS            ;terminal input buffer (TIB)
  88. RPP        EQU    UPP-2        ;start of return stack (RP0)
  89. SPP        EQU    RPP-RTS        ;start of data stack (SP0)
  90. NAMEE        EQU    BM+1FFEH        ;initial name dictionary******
  91. CODEE        EQU    BM+100H        ;initial code dictionary******
  92.  
  93. ;; Initialize assembly variables
  94.  
  95. _LINK    = 0                    ;force a null link
  96. _NAME    = NAMEE                    ;initialize name pointer
  97. _CODE    = CODEE                    ;initialize code pointer
  98. _USER    = 4*CELLL                ;first user variable offset
  99.  
  100. ;; Define assembly macros
  101.  
  102. ;    Adjust an address to the next cell boundary.
  103.  
  104. $ALIGN    MACRO
  105.     EVEN                    ;;for 16bit systems
  106.     ENDM
  107.  
  108. ;    Compile a code definition header.
  109.  
  110. $CODE    MACRO    LEX,NAME,LABEL
  111.     $ALIGN                    ;;force to cell boundary
  112. LABEL:                        ;;assembly label
  113.     _CODE    = $                ;;save code pointer
  114.     _LEN    = (LEX AND 01FH)/CELLL        ;;string cell count, round down
  115.     _NAME    = _NAME-((_LEN+3)*CELLL)    ;;new header on cell boundary
  116. ORG    _NAME                    ;;set name pointer
  117.     DW     _CODE,_LINK            ;;token pointer and link
  118.     _LINK    = $                ;;link points to a name string
  119.     DB    LEX,NAME            ;;name string
  120. ORG    _CODE                    ;;restore code pointer
  121.     ENDM
  122.  
  123. ;    Compile a colon definition header.
  124.  
  125. $COLON    MACRO    LEX,NAME,LABEL
  126.     $CODE    LEX,NAME,LABEL
  127.     DW    CALLL                ;;align to cell boundary******
  128.     DW    LISTT                ;;include CALL doLIST******
  129.     ENDM
  130.  
  131. ;    Compile a user variable header.
  132.  
  133. $USER    MACRO    LEX,NAME,LABEL
  134.     $CODE    LEX,NAME,LABEL
  135.     DW    CALLL                ;;align to cell boundary******
  136.     DW    LISTT                ;;include CALL doLIST******
  137.     DW    DOUSE,_USER            ;;followed by doUSER and offset
  138.     _USER    = _USER+CELLL            ;;update user area offset
  139.     ENDM
  140.  
  141. ;    Compile an inline string.
  142.  
  143. D$    MACRO    FUNCT,STRNG
  144.     DW    FUNCT                ;;function
  145.     _LEN    = $                ;;save address of count byte
  146.     DB    0,STRNG                ;;count byte and string
  147.     _CODE    = $                ;;save code pointer
  148. ORG    _LEN                    ;;point to count byte
  149.     DB    _CODE-_LEN-1            ;;set count
  150. ORG    _CODE                    ;;restore code pointer
  151.     $ALIGN
  152.     ENDM
  153.  
  154.  
  155. ;; Main entry points and COLD start data
  156.  
  157. MAIN    SEGMENT
  158. ASSUME    CS:MAIN,DS:MAIN,ES:MAIN,SS:MAIN
  159.  
  160. ORG    BM                    ;Power up location******
  161.  
  162.     DB    02H,1,0        ;Jump to cold start
  163.     DB    32H,0,0,0,0,0,0,0        ;Return from interrupt
  164.     DB    32H,0,0,0,0,0,0,0        ;Return from interrupt
  165.     DB    32H,0,0,0,0,0,0,0        ;Return from interrupt
  166.     DB    32H,0,0,0,0,0,0,0        ;Return from interrupt
  167.     DB    32H,0,0,0,0,0,0,0        ;Return from interrupt
  168.     DB    32H,0,0,0,0,0,0,0        ;Return from interrupt
  169.     DB    32H,0,0,0,0,0,0,0        ;Return from interrupt
  170.     DB    32H,0,0,0,0
  171.  
  172. ORG    COLDD                    ;User variable initial values
  173.  
  174. ; COLD start moves the following to USER variables.
  175. ; MUST BE IN SAME ORDER AS USER VARIABLES.
  176.  
  177. $ALIGN                        ;align to cell boundary
  178.  
  179. UZERO:        DW    4 DUP (0)        ;reserved
  180.         DW    SPP            ;SP0
  181.         DW    RPP            ;RP0
  182.         DW    QRX            ;'?KEY
  183.         DW    TXSTO            ;'EMIT
  184.         DW    ACCEP            ;'EXPECT
  185.         DW    KTAP            ;'TAP
  186.         DW    TXSTO            ;'ECHO
  187.         DW    DOTOK            ;'PROMPT
  188.         DW    BASEE            ;BASE
  189.         DW    0            ;tmp
  190.         DW    0            ;SPAN
  191.         DW    0            ;>IN
  192.         DW    0            ;#TIB
  193.         DW    TIBB            ;TIB
  194.         DW    0            ;CSP
  195.         DW    INTER            ;'EVAL
  196.         DW    NUMBQ            ;'NUMBER
  197.         DW    0            ;HLD
  198.         DW    0            ;HANDLER
  199.         DW    0            ;CONTEXT pointer
  200.         DW    VOCSS DUP (0)        ;vocabulary stack
  201.         DW    0            ;CURRENT pointer
  202.         DW    0            ;vocabulary link pointer
  203.         DW    EM-2000H            ;CP******
  204.         DW    SPP-DTS            ;NP
  205.         DW    LASTN            ;LAST
  206.         DW    LASTN            ;FORTH
  207.         DW    0            ;vocabulary link
  208. ULAST:
  209.  
  210. ORG    CODEE                    ;start code dictionary
  211.  
  212. ORIG:    ;Cold boot routine
  213.  
  214.     DB    75H,0A8H,0H        ;MOV IE,#0H
  215.     DB    75H,81H,10H        ;MOV SP,#10H
  216.     DB    75H,0D0H,08H        ;MOV PSW,#8
  217.     DB    79H,0FEH        ;MOV RPL,#0FEH
  218.     DB    75H,04H,7FH        ;MOV RPH,#7EH
  219.     DB    075H,006H,000H        ;MOV UPL,#0
  220.     DB    075H,007H,07FH        ;MOV UPH,#7FH
  221.     DB    078H,0FEH        ;MOV SPL,#0FEH
  222.     DB    075H,005H,07DH        ;MOV SPH,#07DH
  223.     DB    075H,08DH,0FDH        ;MOV TH1,#0FDH 19200 Baud
  224.     DB    075H,087H,080H        ;MOV PCON,#80H
  225.     DB    075H,98H,050H        ;MOV SCON,#50H
  226.     DB    0D2H,08EH        ;SETB TCON.6
  227.     DB    75H,089H,020H        ;MOV TMOD,#20H
  228.     DB    085H,005H,0A0H        ;MOV P2,SPH
  229.     DB    002H,14H,02H        ;LJMP COLD1******to be hand coded!
  230.     DB    0,0,0        ;filler
  231.  
  232. ;;   RETURN
  233.  
  234. RETURN:   ;The Forth Inner Interpreter
  235.     DB    8EH,082H        ;MOV DPL,IPL
  236.     DB    08FH,083H        ;MOV DPH,IPH
  237.     DB    0E4H        ;CLR A
  238.     DB    093H        ;MOVC A,@A+DPTR
  239.     DB    0FCH        ;MOV NPL,A
  240.     DB    074H,001H        ;MOV A,#1
  241.     DB    093H        ;MOVC A,@A+DPTR
  242.     DB    0F5H,083H        ;MOV DPH,A
  243.     DB    08CH,082H        ;MOV DPL,NPL
  244.     DB    0EEH        ;MOV A,IPL
  245.     DB    024H,002H        ;ADD A,#2
  246.     DB    0FEH        ;MOV IPL,A
  247.     DB    050H,001H        ;JNC .+1
  248.     DB    00FH        ;INC IPH
  249.     DB    0E4H        ;CLR A
  250.     DB    073H        ;JMP @A+DPTR
  251.  
  252. ;; The kernel
  253.  
  254. ;   doLIT    ( -- w )
  255. ;        Push an inline literal.
  256.  
  257.         $CODE    COMPO+5,'doLIT',DOLIT
  258.     DB    8EH,082H        ;MOV DPL,IPL
  259.     DB    08FH,083H        ;MOV DPH,IPH
  260.     DB    0EBH        ;MOV A,TPH
  261.     DB    0F2H        ;MOVX @SPL,A
  262.     DB    018H        ;DEC SPL
  263.     DB    0EAH        ;MOV A,TPL
  264.     DB    0F2H        ;MOVX @SPL,A
  265.     DB    018H        ;DEC SPL
  266.     DB    0E4H        ;CLR A
  267.     DB    093H        ;MOVC A,@A+DPTR
  268.     DB    0FAH        ;MOV TPL,A
  269.     DB    0A3H        ;INC DPTR
  270.     DB    0E4H        ;CLR A
  271.     DB    093H        ;MOVC A,@A+DPTR
  272.     DB    0FBH        ;MOV TPH,A
  273.     DB    0A3H        ;INC DPTR
  274.     DB    0AEH,082H        ;MOV IPL,DPL
  275.     DB    0AFH,083H        ;MOV IPH,DPH
  276.     DB    021H,34H        ;AJMP RETURN+4
  277.  
  278. ;   doLIST    ( a -- )
  279. ;        Process colon list.
  280.  
  281.         $CODE    COMPO+6,'doLIST',DOLST
  282.     DB    85H,004H,0A0H        ;MOV P2,RPH Get list address
  283.     DB    0EFH        ;MOV A,IPH
  284.     DB    0F3H        ;MOVX @RPL,A
  285.     DB    019H        ;DEC RPL
  286.     DB    0EEH        ;MOV A,IPL
  287.     DB    0F3H        ;MOVX @RPL,A
  288.     DB    019H        ;DEC RPL
  289.     DB    085H,005H,0A0H        ;MOV P2,SPH Restore stack pointer
  290.     DB    0D0H,00FH        ;POP IPH
  291.     DB    0D0H,0EH        ;POP IPL
  292.     DB    021H,030H        ;AJMP RETURN
  293.  
  294. ;   next    ( -- )
  295. ;        Run time code for the single index loop.
  296. ;        : next ( -- ) \ hilevel model
  297. ;          r> r> dup if 1 - >r @ >r exit then drop cell+ >r ;
  298.  
  299.         $CODE    COMPO+4,'next',DONXT
  300.     DB    85H,004H,0A0H        ;MOV P2,RPH
  301.     DB    009H        ;INC RPL
  302.     DB    0E3H        ;MOVX A,@RPL
  303.     DB    0C3H        ;CLR C
  304.     DB    094H,001H        ;SUBB A,#1
  305.     DB    0F3H        ;MOVX @RPL,A
  306.     DB    009H        ;INC RPL
  307.     DB    0E3H        ;MOVX A,@RPL
  308.     DB    094H,000H        ;SUBB A,#0
  309.     DB    0F3H        ;MOVX @RPL,A
  310.     DB    085H,005H,0A0H        ;MOV P2,SPH
  311.     DB    08EH,082H        ;MOV DPL,IPL
  312.     DB    08FH,083H        ;MOV DPH,IPH
  313.     DB    050H,008H        ;JNC .+8
  314.     DB    0A3H        ;INC DPTR
  315.     DB    0A3H        ;INC DPTR
  316.     DB    0AEH,082H        ;MOV IPL,DPL
  317.     DB    0AFH,083H        ;MOV IPH,DPH
  318.     DB    021H,030H        ;AJMP RETURN
  319.     DB    019H        ;DEC RPL
  320.     DB    019H        ;DEC RPL
  321.     DB    0E4H        ;CLR A
  322.     DB    093H        ;MOVC A,@A+DPTR
  323.     DB    0FEH        ;MOV IPL,A
  324.     DB    074H,001H        ;MOV A,#1
  325.     DB    093H        ;MOVC A,@A+DPTR
  326.     DB    0FFH        ;MOV IPH,A
  327.     DB    021H,030H        ;AJMP RETURN
  328.  
  329. ;   ?branch    ( f -- )
  330. ;        Branch if flag is zero.
  331.  
  332.         $CODE    COMPO+7,'?branch',QBRAN
  333.     DB    8EH,082H        ;MOV DPL,IPL
  334.     DB    08FH,83H        ;MOV DPH,IPH
  335.     DB    0EAH        ;MOV A,TPL
  336.     DB    04BH        ;ORL A,TPH
  337.     DB    060H,00EH        ;JZ .+0EH
  338.     DB    0A3H        ;INC DPTR
  339.     DB    0A3H        ;INC DPTR
  340.     DB    0AEH,082H        ;MOV IPL,DPL
  341.     DB    0AFH,083H        ;MOV IPH,DPH
  342.     DB    008H        ;INC SPL
  343.     DB    0E2H        ;MOVX A,@SPL
  344.     DB    0FAH        ;MOV TPL,A
  345.     DB    008H        ;INC SPL
  346.     DB    0E2H        ;MOVX A,@SPL
  347.     DB    0FBH        ;MOV TPH,A
  348.     DB    021H,030H        ;AJMP RETURN
  349.     DB    0E4H        ;CLR A
  350.     DB    093H        ;MOVC A,@A+DPTR
  351.     DB    0FEH        ;MOV IPL,A
  352.     DB    074H,001H        ;MOV A,#1
  353.     DB    093H        ;MOVC A,@A+DPTR
  354.     DB    0FFH        ;MOV IPH,A
  355.     DB    008H        ;INC SPL
  356.     DB    0E2H        ;MOVX A,@SPL
  357.     DB    0FAH        ;MOV TPL,A
  358.     DB    008H        ;INC SPL
  359.     DB    0E2H        ;MOVX A,@SPL
  360.     DB    0FBH        ;MOV TPH,A
  361.     DB    021H,030H        ;AJMP RETURN
  362.  
  363. ;   branch    ( -- )
  364. ;        Branch to an inline address.
  365.  
  366.         $CODE    COMPO+6,'branch',BRAN
  367.     DB    8EH,082H        ;MOV DPL,IPL
  368.     DB    08FH,083H        ;MOV DPH,IPH
  369.     DB    0E4H        ;CLR A
  370.     DB    093H        ;MOVC A,@A+DPTR
  371.     DB    0FEH        ;MOV IPL,A
  372.     DB    074H,001H        ;MOV A,#1
  373.     DB    093H        ;MOVC A,@A+DPTR
  374.     DB    0FFH        ;MOV IPH,A
  375.     DB    021H,030H        ;AJMP RETURN
  376.  
  377. ;   EXECUTE    ( ca -- )
  378. ;        Execute the word at ca.
  379.  
  380.         $CODE    7,'EXECUTE',EXECU
  381.     DB    8AH,082H        ;MOV DPL,TPL
  382.     DB    08BH,083H        ;MOV DPH,TPH
  383.     DB    008H        ;INC SPL
  384.     DB    0E2H        ;MOVX A,@SPL
  385.     DB    0FAH        ;MOV TPL,A
  386.     DB    008H        ;INC SPL
  387.     DB    0E2H        ;MOVX A,@SPL
  388.     DB    0FBH        ;MOV TPH,A
  389.     DB    0E4H        ;CLR A
  390.     DB    073H        ;JMP @A+DPTR
  391.  
  392. ;   EXIT    ( -- )
  393. ;        Terminate a colon definition.
  394.  
  395.         $CODE    4,'EXIT',EXIT
  396.     DB    85H,004H,0A0H        ;MOV P2,RPH
  397.     DB    09H        ;INC RPL
  398.     DB    0E3H        ;MOV A,@PRL
  399.     DB    0FEH        ;MOV IPL,A
  400.     DB    009H        ;INC RPL
  401.     DB    0E3H        ;MOV A,@RPL
  402.     DB    0FFH        ;MOV IPH,A
  403.     DB    085H,005H,0A0H        ;MOV P2,SPH
  404.     DB    021H,030H        ;AJMP RETURN
  405.  
  406. ;   !        ( w a -- )
  407. ;        Pop the data stack to memory.
  408.  
  409.         $CODE    1,'!',STORE
  410.     DB    8AH,082H        ;MOV DPL,TPL
  411.     DB    08BH,083H        ;MOV DPH,TPH
  412.     DB    008H        ;INC SPL
  413.     DB    0E2H        ;MOV A,@SPL
  414.     DB    0F0H        ;MOVX @DPTR,A
  415.     DB    0A3H        ;INC DPTR
  416.     DB    008H        ;INC SPL
  417.     DB    0E2H        ;MOV A,@SPL
  418.     DB    0F0H        ;MOVX @DPTR,A
  419.     DB    008H        ;INC SPL
  420.     DB    0E2H        ;MOV A,@SPL
  421.     DB    0FAH        ;MOV TPL,A
  422.     DB    008H        ;INC SPL
  423.     DB    0E2H        ;MOV A,@SPL
  424.     DB    0FBH        ;MOV TPH,A
  425.     DB    021H,030H        ;AJMP RETURN
  426.  
  427. ;   @        ( a -- w )
  428. ;        Push memory location to the data stack.
  429.  
  430.         $CODE    1,'@',AT
  431.     DB    8AH,082H        ;MOV DPL,TPL
  432.     DB    8BH,083H        ;MOV DPH,TPH
  433.     DB    0E0H        ;MOVX A,@DPTR
  434.     DB    0FAH        ;MOV TPL,A
  435.     DB    0A3H        ;INC DPTR
  436.     DB    0E0H        ;MOVX A,@DPTR
  437.     DB    0FBH        ;MOV TPH,A
  438.     DB    021H,030H        ;AJMP RETURN
  439.  
  440. ;   C!        ( c b -- )
  441. ;        Pop the data stack to byte memory.
  442.  
  443.         $CODE    2,'C!',CSTOR
  444.     DB    8AH,082H        ;MOV DPL,TPL
  445.     DB    08BH,083H        ;MOV DPH,TPH
  446.     DB    008H        ;INC SPL
  447.     DB    0E2H        ;MOVX A,@SPL
  448.     DB    0F0H        ;MOVX @DPTR,A
  449.     DB    08H        ;INC SPL
  450.     DB    0E2H        ;MOVX A,@SPL
  451.     DB    008H        ;INC SPL
  452.     DB    0E2H        ;MOVX A,@DPTR
  453.     DB    0FAH        ;MOV TPL,A
  454.     DB    008H        ;INC SPL
  455.     DB    0E2H        ;MOVX A,@SPL
  456.     DB    0FBH        ;MOV TPH,A
  457.     DB    021H,030H        ;AJMP RETURN
  458.  
  459. ;   C@        ( b -- c )
  460. ;        Push byte memory location to the data stack.
  461.  
  462.         $CODE    2,'C@',CAT
  463.     DB    8AH,082H        ;MOV DPL,TPL
  464.     DB    08BH,083H        ;MOV DPH,TPH
  465.     DB    0E0H        ;MOVX A,@DPTR
  466.     DB    0FAH        ;MOV TPL,A
  467.     DB    7BH,000H        ;MOV TPH,#0
  468.     DB    021H,030H        ;AJMP RETURN
  469.  
  470. ;   >R        ( w -- )
  471. ;        Push the data stack to the return stack.
  472.  
  473.         $CODE    COMPO+2,'>R',TOR
  474.     DB    85H,004H,0A0H        ;MOV P2,RPH
  475.     DB    0EBH        ;MOV A,TPH
  476.     DB    0F3H        ;MOVX @RPL,A
  477.     DB    019H        ;INC RPL
  478.     DB    0EAH        ;MOV A,TPL
  479.     DB    0F3H        ;MOVX @RPL,A
  480.     DB    019H        ;INC RPL
  481.     DB    085H,005H,0A0H        ;MOV P2,SPH
  482.     DB    008H        ;INC SPL
  483.     DB    0E2H        ;MOVX A,@SPL
  484.     DB    0FAH        ;MOV TPL,A
  485.     DB    008H        ;INC SPL
  486.     DB    0E2H        ;MOVX A,@SPL
  487.     DB    0FBH        ;MOV TPH,A
  488.     DB    021H,030H        ;AJMP RETURN
  489.  
  490. ;   R@        ( -- w )
  491. ;        Copy top of return stack to the data stack.
  492.  
  493.         $CODE    2,'R@',RAT
  494.     DB    0EBH        ;MOV A,TPH
  495.     DB    0F2H        ;MOVX @SPL,A
  496.     DB    018H        ;DEC SPL
  497.     DB    0EAH        ;MOV A,TPL
  498.     DB    0F2H        ;MOVX @SPL,A
  499.     DB    018H        ;DEC SPL
  500.     DB    089H,082H        ;MOV DPL,RPL
  501.     DB    085H,004H,083H        ;MOV DPH,RPH
  502.     DB    005H,082H        ;INC DPL
  503.     DB    0E0H        ;MOVX A,@DPTR
  504.     DB    0FAH        ;MOV DPL,A
  505.     DB    005H,082H        ;INC DPL
  506.     DB    0E0H        ;MOVX A,@DPTR
  507.     DB    0FBH        ;MOV DPH,A
  508.     DB    021H,030H        ;AJMP RETURN
  509.  
  510. ;   R>        ( -- w )
  511. ;        Pop the return stack to the data stack.
  512.  
  513.         $CODE    2,'R>',RFROM
  514.     DB    0EBH        ;MOV A,TPH
  515.     DB    0F2H        ;MOVX @SPL,A
  516.     DB    018H        ;DEC SPL
  517.     DB    0EAH        ;MOV A,TPL
  518.     DB    0F2H        ;MOVX @SPL,A
  519.     DB    018H        ;DEC SPL
  520.     DB    085H,004H,0A0H        ;MOV P2,RPH
  521.     DB    009H        ;INC RPL
  522.     DB    0E3H        ;MOVX A,@RPL
  523.     DB    0FAH        ;MOV TPL,A
  524.     DB    009H        ;INC RPL
  525.     DB    0E3H        ;MOVX A,@RPL
  526.     DB    0FBH        ;MOV TPH,A
  527.     DB    085H,005H,0A0H        ;MOV P2,SPH
  528.     DB    021H,030H        ;AJMP RETURN
  529.  
  530. ;   RP@        ( -- a )
  531. ;        Push the current RP to the data stack.
  532.  
  533.         $CODE    3,'RP@',RPAT
  534.     DB    0EBH        ;MOV A,TPH
  535.     DB    0F2H        ;MOVX @SPL,A
  536.     DB    018H        ;DEC SPL
  537.     DB    0EAH        ;MOV A,TPL
  538.     DB    0F2H        ;MOVX @SPL,A
  539.     DB    018H        ;DEC SPL
  540.     DB    089H,00AH        ;MOV TPL,RPL
  541.     DB    085H,004H,00BH        ;MOV TPH,RPH
  542.     DB    021H,030H        ;AJMP RETURN
  543.  
  544. ;   RP!        ( a -- )
  545. ;        Set the return stack pointer.
  546.  
  547.         $CODE    COMPO+3,'RP!',RPSTO
  548.     DB    8AH,009H        ;MOV RPL,TPL
  549.     DB    08BH,004H        ;MOV RPH,TPH
  550.     DB    008H        ;INC SPL
  551.     DB    0E2H        ;MOV A,@SPL
  552.     DB    0FAH        ;MOV TPL,A
  553.     DB    008H        ;INC SPL
  554.     DB    0E2H        ;MOV A,@SPL
  555.     DB    0FBH        ;MOV TPH,A
  556.     DB    021H,030H        ;AJMP RETURN
  557.  
  558. ;   SP@        ( -- a )
  559. ;        Push the current data stack pointer.
  560.  
  561.         $CODE    3,'SP@',SPAT
  562.     DB    0EBH        ;MOV A,TPH
  563.     DB    0F2H        ;MOVX @SPL,A
  564.     DB    018H        ;DEC SPL
  565.     DB    0EAH        ;MOV A,TPL
  566.     DB    0F2H        ;MOVX @SPL,A
  567.     DB    018H        ;DEC SPL
  568.     DB    088H,00AH        ;MOV TPL,SPL
  569.     DB    085H,005H,00BH;MOV TPH,SPH
  570.     DB    021H,030H        ;AJMP RETURN
  571.  
  572. ;   SP!        ( a -- )
  573. ;        Set the data stack pointer.
  574.  
  575.         $CODE    3,'SP!',SPSTO
  576.     DB    8AH,008H        ;MOV SPL,TPL
  577.     DB    08BH,005H        ;MOV SPH,TPH
  578.     DB    008H        ;INC SPL
  579.     DB    0E2H        ;MOVX A,@SPL
  580.     DB    0FAH        ;MOV TPL,A
  581.     DB    008H        ;INC SPL
  582.     DB    0E2H        ;MOVX A,@SPL
  583.     DB    0FBH        ;MOV TPH,A
  584.     DB    021H,030H        ;AJMP RETURN
  585.  
  586. ;   DUP        ( w -- w w )
  587. ;        Duplicate the top stack item.
  588.  
  589.         $CODE    3,'DUP',DUPP
  590.     DB    0EBH        ;MOV A,TPH
  591.     DB    0F2H        ;MOVX @SPL,A
  592.     DB    018H        ;DEC SPL
  593.     DB    0EAH        ;MOV A,TPL
  594.     DB    0F2H        ;MOVX @SPL,A
  595.     DB    018H        ;DEC SPL
  596.     DB    021H,030H        ;AJMP RETURN
  597.  
  598. ;   DROP    ( w -- )
  599. ;        Discard top stack item.
  600.  
  601.         $CODE    4,'DROP',DROP
  602.     DB    008H        ;INC SPL
  603.     DB    0E2H        ;MOVX A,@SPL
  604.     DB    0FAH        ;MOV TPL,A
  605.     DB    008H        ;INC SPL
  606.     DB    0E2H        ;MOVX A,@SPL
  607.     DB    0FBH        ;MOV TPH,A
  608.     DB    021H,030H        ;AJMP RETURN
  609.  
  610. ;   SWAP    ( w1 w2 -- w2 w1 )
  611. ;        Exchange top two stack items.
  612.  
  613.         $CODE    4,'SWAP',SWAP
  614.     DB    88H,082H        ;MOV DPL,SPL
  615.     DB    85H,005H,083H        ;MOV DPH,SPH
  616.     DB    005H,082H        ;INC DPL
  617.     DB    0E0H        ;MOVX A,@DPTR
  618.     DB    0CAH        ;XCH A,TPL
  619.     DB    0F0H        ;MOVX @DPTR,A
  620.     DB    005H,082H        ;INC DPL
  621.     DB    0E0H        ;MOVX A,@DPTR
  622.     DB    0CBH        ;XCH A,TPH
  623.     DB    0F0H        ;MOVX @DPTR,A
  624.     DB    021H,030H        ;AJMP RETURN
  625.  
  626. ;   OVER    ( w1 w2 -- w1 w2 w1 )
  627. ;        Copy second stack item to top.
  628.  
  629.         $CODE    4,'OVER',OVER
  630.     DB    88H,82H        ;MOV DPL,SPL
  631.     DB    085H,005H,083H        ;MOV DPH,SPH
  632.     DB    0EBH        ;MOV A,TPH
  633.     DB    0F2H        ;MOVX @SPL,A
  634.     DB    018H        ;DEC SPL
  635.     DB    0EAH        ;MOV A,TPL
  636.     DB    0F2H        ;MOVX @SPL,A
  637.     DB    018H        ;DEC SPL
  638.     DB    005H,082H        ;INC DPL
  639.     DB    0E0H        ;MOVX A,@DPTR
  640.     DB    0FAH        ;MOV TPL,A
  641.     DB    005H,082H        ;INC DPL
  642.     DB    0E0H        ;MOVX A,@DPTR
  643.     DB    0FBH        ;MOV TPH,A
  644.     DB    021H,030H        ;AJMP RETURN
  645.  
  646. ;   0<        ( n -- t )
  647. ;        Return true if n is negative.
  648.  
  649.         $CODE    2,'0<',ZLESS
  650.     DB    0EBH        ;MOV A,TPH
  651.     DB    030H,0E7H,004H        ;JNB ACC.7,$+4
  652.     DB    074H,0FFH        ;MOV A,#0FFH
  653.     DB    080H,001H        ;SJUMP $+1
  654.     DB    0E4H        ;CLR A
  655.     DB    0FBH        ;MOV TPL,A
  656.     DB    0FAH        ;MOV TPH,A
  657.     DB    021H,30H        ;AJMP RETURN
  658.  
  659. ;   AND        ( w w -- w )
  660. ;        Bitwise AND.
  661.  
  662.         $CODE    3,'AND',ANDD
  663.     DB    08H        ;INC SPL
  664.     DB    0E2H        ;MOVX A,@SPL
  665.     DB    052H,00AH        ;ANL TPL,A
  666.     DB    008H        ;INC SPL
  667.     DB    0E2H        ;MOVX A,@SPL
  668.     DB    052H,00BH        ;ANL TPH,A
  669.     DB    021H,030H        ;AJMP RETURN
  670.  
  671. ;   OR        ( w w -- w )
  672. ;        Bitwise inclusive OR.
  673.  
  674.         $CODE    2,'OR',ORR
  675.     DB    08H        ;INC SPL
  676.     DB    0E2H        ;MOV A,@SPL
  677.     DB    042H,00AH        ;ONL TPL,A
  678.     DB    008H        ;INC SPL
  679.     DB    0E2H        ;MOV A,@SPL
  680.     DB    042H,00BH        ;ONL TPH,A
  681.     DB    021H,030H        ;AJMP RETURN
  682.  
  683. ;   XOR        ( w w -- w )
  684. ;        Bitwise exclusive OR.
  685.  
  686.         $CODE    3,'XOR',XORR
  687.     DB    08H        ;INC SPL
  688.     DB    0E2H        ;MOV A,@SPL
  689.     DB    062H,00AH        ;XRL TPL,A
  690.     DB    008H        ;INC SPL
  691.     DB    0E2H        ;MOV A,@SPL
  692.     DB    062H,00BH        ;XRL TPH,A
  693.     DB    021H,030H        ;AJMP RETURN
  694.  
  695. ;   UM+        ( w w -- w cy )
  696. ;        Add two numbers, return the sum and carry flag.
  697.  
  698.         $CODE    3,'UM+',UPLUS
  699.     DB    08H        ;INC SPL
  700.     DB    0E2H        ;MOV A,@SPL
  701.     DB    02AH        ;ADD A,TPL
  702.     DB    0F2H        ;MOVX @SPL,A
  703.     DB    008H        ;INC SPL
  704.     DB    0E2H        ;MOV A,@SPL
  705.     DB    03BH        ;ADDC A,TPH
  706.     DB    0F2H        ;MOVX @SPL,A
  707.     DB    018H        ;DEC SPL
  708.     DB    018H        ;DEC SPL
  709.     DB    0E4H        ;CLR A
  710.     DB    0FBH        ;MOV TPH,A
  711.     DB    03BH        ;ADDC A,TPH
  712.     DB    0FAH        ;MOV TPL,A
  713.     DB    021H,030H        ;AJMP RETURN
  714.  
  715. ;; Device dependent I/O
  716.  
  717. ;   !IO        ( -- )
  718. ;        Initialize the serial I/O devices.
  719.  
  720.         $CODE    3,'!IO',STOIO
  721.     DB    0C2H,0ACH        ;CLR IE.4
  722.     DB    075H,098H,052H        ;MOV SCON,#52H
  723.     DB    021H,030H        ;AJMP RETURN
  724.  
  725. ;   ?RX        ( -- c T | F )
  726. ;        Return input character and true, or a false if no input.
  727.  
  728.         $CODE    3,'?RX',QRX
  729.     DB    0EBH        ;MOV A,TPH
  730.     DB    0F2H        ;MOVX @SPL,A
  731.     DB    018H        ;DEC SPL
  732.     DB    0EAH        ;MOV A,TPL
  733.     DB    0F2H        ;MOVX @SPL,A
  734.     DB    018H        ;DEC SPL
  735.     DB    30H,098H,012H        ;JNB SCON.0,$+12H
  736.     DB    0C2H,098H        ;CLR SCON.0
  737.     DB    0AAH,099H        ;MOV TPL,SBUF
  738.     DB    07BH,000H        ;MOV TPH,#0
  739.     DB    0EBH        ;MOV A,TPH
  740.     DB    0F2H        ;MOVX @SPL,A
  741.     DB    018H        ;DEC SPL
  742.     DB    0EAH        ;MOV A,TPL
  743.     DB    0F2H        ;MOVX @SPL,A
  744.     DB    018H        ;DEC SPL
  745.     DB    07AH,0FFH        ;MOV TPL,#0FFH
  746.     DB    07BH,0FFH        ;MOV TPH,#0FFH
  747.     DB    021H,030H        ;AJMP RETURN
  748.     DB    07AH,000H        ;MOV TPL,#0
  749.     DB    07BH,000H        ;MOV TPH,#0
  750.     DB    021H,030H        ;AJMP RETURN
  751.  
  752. ;   TX!        ( c -- )
  753. ;        Send character c to the output device.
  754.  
  755.         $CODE    3,'TX!',TXSTO
  756.     DB    30H,099H,002H        ;JNB SCON.1,$+2
  757.     DB    0C2H,099H        ;CLR SCON.1
  758.     DB    08AH,099H        ;MOV TPL,SBUF
  759.     DB    030H,099H,0FDH        ;JNB SCON.1,$-3
  760.     DB    0C2H,099H        ;CLR SCON.1
  761.     DB    008H        ;INC SPL
  762.     DB    0E2H        ;MOV A,@SPL
  763.     DB    0FAH        ;MOV TPL,A
  764.     DB    008H        ;INC SPL
  765.     DB    0E2H        ;MOV A,@SPL
  766.     DB    0FBH        ;MOV TPH,A
  767.     DB    021H,030H        ;AJMP RETURN
  768.  
  769. ;; System and user variables
  770.  
  771. ;   doVAR    ( -- a )
  772. ;        Run time routine for VARIABLE and CREATE.
  773.  
  774.         $COLON    COMPO+5,'doVAR',DOVAR
  775.         DW    RFROM,EXIT
  776.  
  777. ;   UP        ( -- a )
  778. ;        Pointer to the user area.
  779.  
  780.         $COLON    2,'UP',UP
  781.         DW    DOVAR
  782.         DW    UPP
  783.  
  784. ;   doUSER    ( -- a )
  785. ;        Run time routine for user variables.
  786.  
  787.         $COLON    COMPO+6,'doUSER',DOUSE
  788.         DW    RFROM,AT,UP,AT,PLUS,EXIT
  789.  
  790. ;   SP0        ( -- a )
  791. ;        Pointer to bottom of the data stack.
  792.  
  793.         $USER    3,'SP0',SZERO
  794.  
  795. ;   RP0        ( -- a )
  796. ;        Pointer to bottom of the return stack.
  797.  
  798.         $USER    3,'RP0',RZERO
  799.  
  800. ;   '?KEY    ( -- a )
  801. ;        Execution vector of ?KEY.
  802.  
  803.         $USER    5,"'?KEY",TQKEY
  804.  
  805. ;   'EMIT    ( -- a )
  806. ;        Execution vector of EMIT.
  807.  
  808.         $USER    5,"'EMIT",TEMIT
  809.  
  810. ;   'EXPECT    ( -- a )
  811. ;        Execution vector of EXPECT.
  812.  
  813.         $USER    7,"'EXPECT",TEXPE
  814.  
  815. ;   'TAP    ( -- a )
  816. ;        Execution vector of TAP.
  817.  
  818.         $USER    4,"'TAP",TTAP
  819.  
  820. ;   'ECHO    ( -- a )
  821. ;        Execution vector of ECHO.
  822.  
  823.         $USER    5,"'ECHO",TECHO
  824.  
  825. ;   'PROMPT    ( -- a )
  826. ;        Execution vector of PROMPT.
  827.  
  828.         $USER    7,"'PROMPT",TPROM
  829.  
  830. ;   BASE    ( -- a )
  831. ;        Storage of the radix base for numeric I/O.
  832.  
  833.         $USER    4,'BASE',BASE
  834.  
  835. ;   tmp        ( -- a )
  836. ;        A temporary storage location used in parse and find.
  837.  
  838.         $USER    COMPO+3,'tmp',TEMP
  839.  
  840. ;   SPAN    ( -- a )
  841. ;        Hold character count received by EXPECT.
  842.  
  843.         $USER    4,'SPAN',SPAN
  844.  
  845. ;   >IN        ( -- a )
  846. ;        Hold the character pointer while parsing input stream.
  847.  
  848.         $USER    3,'>IN',INN
  849.  
  850. ;   #TIB    ( -- a )
  851. ;        Hold the current count and address of the terminal input buffer.
  852.  
  853.         $USER    4,'#TIB',NTIB
  854.         _USER = _USER+CELLL
  855.  
  856. ;   CSP        ( -- a )
  857. ;        Hold the stack pointer for error checking.
  858.  
  859.         $USER    3,'CSP',CSP
  860.  
  861. ;   'EVAL    ( -- a )
  862. ;        Execution vector of EVAL.
  863.  
  864.         $USER    5,"'EVAL",TEVAL
  865.  
  866. ;   'NUMBER    ( -- a )
  867. ;        Execution vector of NUMBER?.
  868.  
  869.         $USER    7,"'NUMBER",TNUMB
  870.  
  871. ;   HLD        ( -- a )
  872. ;        Hold a pointer in building a numeric output string.
  873.  
  874.         $USER    3,'HLD',HLD
  875.  
  876. ;   HANDLER    ( -- a )
  877. ;        Hold the return stack pointer for error handling.
  878.  
  879.         $USER    7,'HANDLER',HANDL
  880.  
  881. ;   CONTEXT    ( -- a )
  882. ;        A area to specify vocabulary search order.
  883.  
  884.         $USER    7,'CONTEXT',CNTXT
  885.         _USER = _USER+VOCSS*CELLL    ;vocabulary stack
  886.  
  887. ;   CURRENT    ( -- a )
  888. ;        Point to the vocabulary to be extended.
  889.  
  890.         $USER    7,'CURRENT',CRRNT
  891.         _USER = _USER+CELLL        ;vocabulary link pointer
  892.  
  893. ;   CP        ( -- a )
  894. ;        Point to the top of the code dictionary.
  895.  
  896.         $USER    2,'CP',CP
  897.  
  898. ;   NP        ( -- a )
  899. ;        Point to the bottom of the name dictionary.
  900.  
  901.         $USER    2,'NP',NP
  902.  
  903. ;   LAST    ( -- a )
  904. ;        Point to the last name in the name dictionary.
  905.  
  906.         $USER    4,'LAST',LAST
  907.  
  908. ;   forth    ( -- a )
  909. ;        Point to the last name in the name dictionary.
  910.  
  911.         $USER    5,'forth',VFRTH
  912.  
  913. ;; Common functions
  914.  
  915. ;   FORTH    ( -- )
  916. ;        Make FORTH the context vocabulary.
  917.  
  918.         $COLON    5,'FORTH',FORTH
  919.         DW    VFRTH,CNTXT,STORE,EXIT
  920.  
  921. ;   ?DUP    ( w -- w w | 0 )
  922. ;        Dup tos if its is not zero.
  923.  
  924.         $COLON    4,'?DUP',QDUP
  925.         DW    DUPP
  926.         DW    QBRAN,QDUP1
  927.         DW    DUPP
  928. QDUP1:        DW    EXIT
  929.  
  930. ;   ROT        ( w1 w2 w3 -- w2 w3 w1 )
  931. ;        Rot 3rd item to top.
  932.  
  933.         $COLON    3,'ROT',ROT
  934.         DW    TOR,SWAP,RFROM,SWAP,EXIT
  935.  
  936. ;   2DROP    ( w w -- )
  937. ;        Discard two items on stack.
  938.  
  939.         $COLON    5,'2DROP',DDROP
  940.         DW    DROP,DROP,EXIT
  941.  
  942. ;   2DUP    ( w1 w2 -- w1 w2 w1 w2 )
  943. ;        Duplicate top two items.
  944.  
  945.         $COLON    4,'2DUP',DDUP
  946.         DW    OVER,OVER,EXIT
  947.  
  948. ;   +        ( w w -- sum )
  949. ;        Add top two items.
  950.  
  951.         $COLON    1,'+',PLUS
  952.         DW    UPLUS,DROP,EXIT
  953.  
  954. ;   D+        ( d d -- d )
  955. ;        Double addition, as an example using UM+.
  956. ;
  957. ;        $COLON    2,'D+',DPLUS
  958. ;        DW    TOR,SWAP,TOR,UPLUS
  959. ;        DW    RFROM,RFROM,PLUS,PLUS,EXIT
  960.  
  961. ;   NOT        ( w -- w )
  962. ;        One's complement of tos.
  963.  
  964.         $COLON    3,'NOT',INVER
  965.         DW    DOLIT,-1,XORR,EXIT
  966.  
  967. ;   NEGATE    ( n -- -n )
  968. ;        Two's complement of tos.
  969.  
  970.         $COLON    6,'NEGATE',NEGAT
  971.         DW    INVER,DOLIT,1,PLUS,EXIT
  972.  
  973. ;   DNEGATE    ( d -- -d )
  974. ;        Two's complement of top double.
  975.  
  976.         $COLON    7,'DNEGATE',DNEGA
  977.         DW    INVER,TOR,INVER
  978.         DW    DOLIT,1,UPLUS
  979.         DW    RFROM,PLUS,EXIT
  980.  
  981. ;   -        ( n1 n2 -- n1-n2 )
  982. ;        Subtraction.
  983.  
  984.         $COLON    1,'-',SUBB
  985.         DW    NEGAT,PLUS,EXIT
  986.  
  987. ;   ABS        ( n -- n )
  988. ;        Return the absolute value of n.
  989.  
  990.         $COLON    3,'ABS',ABSS
  991.         DW    DUPP,ZLESS
  992.         DW    QBRAN,ABS1
  993.         DW    NEGAT
  994. ABS1:        DW    EXIT
  995.  
  996. ;   =        ( w w -- t )
  997. ;        Return true if top two are equal.
  998.  
  999.         $COLON    1,'=',EQUAL
  1000.         DW    XORR
  1001.         DW    QBRAN,EQU1
  1002.         DW    DOLIT,0,EXIT        ;false flag
  1003. EQU1:        DW    DOLIT,-1,EXIT        ;true flag
  1004.  
  1005. ;   U<        ( u u -- t )
  1006. ;        Unsigned compare of top two items.
  1007.  
  1008.         $COLON    2,'U<',ULESS
  1009.         DW    DDUP,XORR,ZLESS
  1010.         DW    QBRAN,ULES1
  1011.         DW    SWAP,DROP,ZLESS,EXIT
  1012. ULES1:        DW    SUBB,ZLESS,EXIT
  1013.  
  1014. ;   <        ( n1 n2 -- t )
  1015. ;        Signed compare of top two items.
  1016.  
  1017.         $COLON    1,'<',LESS
  1018.         DW    DDUP,XORR,ZLESS
  1019.         DW    QBRAN,LESS1
  1020.         DW    DROP,ZLESS,EXIT
  1021. LESS1:        DW    SUBB,ZLESS,EXIT
  1022.  
  1023. ;   MAX        ( n n -- n )
  1024. ;        Return the greater of two top stack items.
  1025.  
  1026.         $COLON    3,'MAX',MAX
  1027.         DW    DDUP,LESS
  1028.         DW    QBRAN,MAX1
  1029.         DW    SWAP
  1030. MAX1:        DW    DROP,EXIT
  1031.  
  1032. ;   MIN        ( n n -- n )
  1033. ;        Return the smaller of top two stack items.
  1034.  
  1035.         $COLON    3,'MIN',MIN
  1036.         DW    DDUP,SWAP,LESS
  1037.         DW    QBRAN,MIN1
  1038.         DW    SWAP
  1039. MIN1:        DW    DROP,EXIT
  1040.  
  1041. ;   WITHIN    ( u ul uh -- t )
  1042. ;        Return true if u is within the range of ul and uh.
  1043.  
  1044.         $COLON    6,'WITHIN',WITHI
  1045.         DW    OVER,SUBB,TOR            ;ul <= u < uh
  1046.         DW    SUBB,RFROM,ULESS,EXIT
  1047.  
  1048. ;; Divide
  1049.  
  1050. ;   UM/MOD    ( udl udh u -- ur uq )
  1051. ;        Unsigned divide of a double by a single. Return mod and quotient.
  1052.  
  1053.         $COLON    6,'UM/MOD',UMMOD
  1054.         DW    DDUP,ULESS
  1055.         DW    QBRAN,UMM4
  1056.         DW    NEGAT,DOLIT,15,TOR
  1057. UMM1:        DW    TOR,DUPP,UPLUS
  1058.         DW    TOR,TOR,DUPP,UPLUS
  1059.         DW    RFROM,PLUS,DUPP
  1060.         DW    RFROM,RAT,SWAP,TOR
  1061.         DW    UPLUS,RFROM,ORR
  1062.         DW    QBRAN,UMM2
  1063.         DW    TOR,DROP,DOLIT,1,PLUS,RFROM
  1064.         DW    BRAN,UMM3
  1065. UMM2:        DW    DROP
  1066. UMM3:        DW    RFROM
  1067.         DW    DONXT,UMM1
  1068.         DW    DROP,SWAP,EXIT
  1069. UMM4:        DW    DROP,DDROP
  1070.         DW    DOLIT,-1,DUPP,EXIT    ;overflow, return max
  1071.  
  1072. ;   M/MOD    ( d n -- r q )
  1073. ;        Signed floored divide of double by single. Return mod and quotient.
  1074.  
  1075.         $COLON    5,'M/MOD',MSMOD
  1076.         DW    DUPP,ZLESS,DUPP,TOR
  1077.         DW    QBRAN,MMOD1
  1078.         DW    NEGAT,TOR,DNEGA,RFROM
  1079. MMOD1:        DW    TOR,DUPP,ZLESS
  1080.         DW    QBRAN,MMOD2
  1081.         DW    RAT,PLUS
  1082. MMOD2:        DW    RFROM,UMMOD,RFROM
  1083.         DW    QBRAN,MMOD3
  1084.         DW    SWAP,NEGAT,SWAP
  1085. MMOD3:        DW    EXIT
  1086.  
  1087. ;   /MOD    ( n n -- r q )
  1088. ;        Signed divide. Return mod and quotient.
  1089.  
  1090.         $COLON    4,'/MOD',SLMOD
  1091.         DW    OVER,ZLESS,SWAP,MSMOD,EXIT
  1092.  
  1093. ;   MOD        ( n n -- r )
  1094. ;        Signed divide. Return mod only.
  1095.  
  1096.         $COLON    3,'MOD',MODD
  1097.         DW    SLMOD,DROP,EXIT
  1098.  
  1099. ;   /        ( n n -- q )
  1100. ;        Signed divide. Return quotient only.
  1101.  
  1102.         $COLON    1,'/',SLASH
  1103.         DW    SLMOD,SWAP,DROP,EXIT
  1104.  
  1105. ;; Multiply
  1106.  
  1107. ;   UM*        ( u u -- ud )
  1108. ;        Unsigned multiply. Return double product.
  1109.  
  1110.         $COLON    3,'UM*',UMSTA
  1111.         DW    DOLIT,0,SWAP,DOLIT,15,TOR
  1112. UMST1:        DW    DUPP,UPLUS,TOR,TOR
  1113.         DW    DUPP,UPLUS,RFROM,PLUS,RFROM
  1114.         DW    QBRAN,UMST2
  1115.         DW    TOR,OVER,UPLUS,RFROM,PLUS
  1116. UMST2:        DW    DONXT,UMST1
  1117.         DW    ROT,DROP,EXIT
  1118.  
  1119. ;   *        ( n n -- n )
  1120. ;        Signed multiply. Return single product.
  1121.  
  1122.         $COLON    1,'*',STAR
  1123.         DW    UMSTA,DROP,EXIT
  1124.  
  1125. ;   M*        ( n n -- d )
  1126. ;        Signed multiply. Return double product.
  1127.  
  1128.         $COLON    2,'M*',MSTAR
  1129.         DW    DDUP,XORR,ZLESS,TOR
  1130.         DW    ABSS,SWAP,ABSS,UMSTA
  1131.         DW    RFROM
  1132.         DW    QBRAN,MSTA1
  1133.         DW    DNEGA
  1134. MSTA1:        DW    EXIT
  1135.  
  1136. ;   */MOD    ( n1 n2 n3 -- r q )
  1137. ;        Multiply n1 and n2, then divide by n3. Return mod and quotient.
  1138.  
  1139.         $COLON    5,'*/MOD',SSMOD
  1140.         DW    TOR,MSTAR,RFROM,MSMOD,EXIT
  1141.  
  1142. ;   */        ( n1 n2 n3 -- q )
  1143. ;        Multiply n1 by n2, then divide by n3. Return quotient only.
  1144.  
  1145.         $COLON    2,'*/',STASL
  1146.         DW    SSMOD,SWAP,DROP,EXIT
  1147.  
  1148. ;; Miscellaneous
  1149.  
  1150. ;   CELL+    ( a -- a )
  1151. ;        Add cell size in byte to address.
  1152.  
  1153.         $COLON    5,'CELL+',CELLP
  1154.         DW    DOLIT,CELLL,PLUS,EXIT
  1155.  
  1156. ;   CELL-    ( a -- a )
  1157. ;        Subtract cell size in byte from address.
  1158.  
  1159.         $COLON    5,'CELL-',CELLM
  1160.         DW    DOLIT,0-CELLL,PLUS,EXIT
  1161.  
  1162. ;   CELLS    ( n -- n )
  1163. ;        Multiply tos by cell size in bytes.
  1164.  
  1165.         $COLON    5,'CELLS',CELLS
  1166.         DW    DOLIT,CELLL,STAR,EXIT
  1167.  
  1168. ;   ALIGNED    ( b -- a )
  1169. ;        Align address to the cell boundary.
  1170.  
  1171.         $COLON    7,'ALIGNED',ALGND
  1172.         DW    DUPP,DOLIT,0,DOLIT,CELLL
  1173.         DW    UMMOD,DROP,DUPP
  1174.         DW    QBRAN,ALGN1
  1175.         DW    DOLIT,CELLL,SWAP,SUBB
  1176. ALGN1:        DW    PLUS,EXIT
  1177.  
  1178. ;   BL        ( -- 32 )
  1179. ;        Return 32, the blank character.
  1180.  
  1181.         $COLON    2,'BL',BLANK
  1182.         DW    DOLIT,' ',EXIT
  1183.  
  1184. ;   >CHAR    ( c -- c )
  1185. ;        Filter non-printing characters.
  1186.  
  1187.         $COLON    5,'>CHAR',TCHAR
  1188.         DW    DOLIT,07FH,ANDD,DUPP    ;mask msb
  1189.         DW    DOLIT,127,BLANK,WITHI    ;check for printable
  1190.         DW    QBRAN,TCHA1
  1191.         DW    DROP,DOLIT,'_'        ;replace non-printables
  1192. TCHA1:        DW    EXIT
  1193.  
  1194. ;   DEPTH    ( -- n )
  1195. ;        Return the depth of the data stack.
  1196.  
  1197.         $COLON    5,'DEPTH',DEPTH
  1198.         DW    SPAT,SZERO,AT,SWAP,SUBB
  1199.         DW    DOLIT,CELLL,SLASH,EXIT
  1200.  
  1201. ;   PICK    ( ... +n -- ... w )
  1202. ;        Copy the nth stack item to tos.
  1203.  
  1204.         $COLON    4,'PICK',PICK
  1205.         DW    DOLIT,1,PLUS,CELLS
  1206.         DW    DOLIT,1,PLUS
  1207.         DW    SPAT,PLUS,AT,EXIT
  1208.  
  1209. ;; Memory access
  1210.  
  1211. ;   +!        ( n a -- )
  1212. ;        Add n to the contents at address a.
  1213.  
  1214.         $COLON    2,'+!',PSTOR
  1215.         DW    SWAP,OVER,AT,PLUS
  1216.         DW    SWAP,STORE,EXIT
  1217.  
  1218. ;   2!        ( d a -- )
  1219. ;        Store the double integer to address a.
  1220.  
  1221.         $COLON    2,'2!',DSTOR
  1222.         DW    SWAP,OVER,STORE
  1223.         DW    CELLP,STORE,EXIT
  1224.  
  1225. ;   2@        ( a -- d )
  1226. ;        Fetch double integer from address a.
  1227.  
  1228.         $COLON    2,'2@',DAT
  1229.         DW    DUPP,CELLP,AT
  1230.         DW    SWAP,AT,EXIT
  1231.  
  1232. ;   COUNT    ( b -- b +n )
  1233. ;        Return count byte of a string and add 1 to byte address.
  1234.  
  1235.         $COLON    5,'COUNT',COUNT
  1236.         DW    DUPP,DOLIT,1,PLUS
  1237.         DW    SWAP,CAT,EXIT
  1238.  
  1239. ;   HERE    ( -- a )
  1240. ;        Return the top of the code dictionary.
  1241.  
  1242.         $COLON    4,'HERE',HERE
  1243.         DW    CP,AT,EXIT
  1244.  
  1245. ;   PAD        ( -- a )
  1246. ;        Return the address of a temporary buffer.
  1247.  
  1248.         $COLON    3,'PAD',PAD
  1249.         DW    HERE,DOLIT,80,PLUS,EXIT
  1250.  
  1251. ;   TIB        ( -- a )
  1252. ;        Return the address of the terminal input buffer.
  1253.  
  1254.         $COLON    3,'TIB',TIB
  1255.         DW    NTIB,CELLP,AT,EXIT
  1256.  
  1257. ;   @EXECUTE    ( a -- )
  1258. ;        Execute vector stored in address a.
  1259.  
  1260.         $COLON    8,'@EXECUTE',ATEXE
  1261.         DW    AT,QDUP            ;?address or zero
  1262.         DW    QBRAN,EXE1
  1263.         DW    EXECU            ;execute if non-zero
  1264. EXE1:        DW    EXIT            ;do nothing if zero
  1265.  
  1266. ;   CMOVE    ( b1 b2 u -- )
  1267. ;        Copy u bytes from b1 to b2.
  1268.  
  1269.         $COLON    5,'CMOVE',CMOVE
  1270.         DW    TOR
  1271.         DW    BRAN,CMOV2
  1272. CMOV1:        DW    TOR,DUPP,CAT
  1273.         DW    RAT,CSTOR
  1274.         DW    DOLIT,1,PLUS
  1275.         DW    RFROM,DOLIT,1,PLUS
  1276. CMOV2:        DW    DONXT,CMOV1
  1277.         DW    DDROP,EXIT
  1278.  
  1279. ;   FILL    ( b u c -- )
  1280. ;        Fill u bytes of character c to area beginning at b.
  1281.  
  1282.         $COLON    4,'FILL',FILL
  1283.         DW    SWAP,TOR,SWAP
  1284.         DW    BRAN,FILL2
  1285. FILL1:        DW    DDUP,CSTOR,DOLIT,1,PLUS
  1286. FILL2:        DW    DONXT,FILL1
  1287.         DW    DDROP,EXIT
  1288.  
  1289. ;   -TRAILING    ( b u -- b u )
  1290. ;        Adjust the count to eliminate trailing white space.
  1291.  
  1292.         $COLON    9,'-TRAILING',DTRAI
  1293.         DW    TOR
  1294.         DW    BRAN,DTRA2
  1295. DTRA1:        DW    BLANK,OVER,RAT,PLUS,CAT,LESS
  1296.         DW    QBRAN,DTRA2
  1297.         DW    RFROM,DOLIT,1,PLUS,EXIT    ;adjusted count
  1298. DTRA2:        DW    DONXT,DTRA1
  1299.         DW    DOLIT,0,EXIT        ;count=0
  1300.  
  1301. ;   PACK$    ( b u a -- a )
  1302. ;        Build a counted string with u characters from b. Null fill.
  1303.  
  1304.         $COLON    5,'PACK$',PACKS
  1305.         DW    ALGND,DUPP,TOR        ;strings only on cell boundary
  1306.         DW    OVER,DUPP,DOLIT,0
  1307.         DW    DOLIT,CELLL,UMMOD,DROP    ;count mod cell
  1308.         DW    SUBB,OVER,PLUS
  1309.         DW    DOLIT,0,SWAP,STORE    ;null fill cell
  1310.         DW    DDUP,CSTOR,DOLIT,1,PLUS    ;save count
  1311.         DW    SWAP,CMOVE,RFROM,EXIT    ;move string
  1312.  
  1313. ;; Numeric output, single precision
  1314.  
  1315. ;   DIGIT    ( u -- c )
  1316. ;        Convert digit u to a character.
  1317.  
  1318.         $COLON    5,'DIGIT',DIGIT
  1319.         DW    DOLIT,9,OVER,LESS
  1320.         DW    DOLIT,7,ANDD,PLUS
  1321.         DW    DOLIT,'0',PLUS,EXIT
  1322.  
  1323. ;   EXTRACT    ( n base -- n c )
  1324. ;        Extract the least significant digit from n.
  1325.  
  1326.         $COLON    7,'EXTRACT',EXTRC
  1327.         DW    DOLIT,0,SWAP,UMMOD
  1328.         DW    SWAP,DIGIT,EXIT
  1329.  
  1330. ;   <#        ( -- )
  1331. ;        Initiate the numeric output process.
  1332.  
  1333.         $COLON    2,'<#',BDIGS
  1334.         DW    PAD,HLD,STORE,EXIT
  1335.  
  1336. ;   HOLD    ( c -- )
  1337. ;        Insert a character into the numeric output string.
  1338.  
  1339.         $COLON    4,'HOLD',HOLD
  1340.         DW    HLD,AT,DOLIT,1,SUBB
  1341.         DW    DUPP,HLD,STORE,CSTOR,EXIT
  1342.  
  1343. ;   #        ( u -- u )
  1344. ;        Extract one digit from u and append the digit to output string.
  1345.  
  1346.         $COLON    1,'#',DIG
  1347.         DW    BASE,AT,EXTRC,HOLD,EXIT
  1348.  
  1349. ;   #S        ( u -- 0 )
  1350. ;        Convert u until all digits are added to the output string.
  1351.  
  1352.         $COLON    2,'#S',DIGS
  1353. DIGS1:        DW    DIG,DUPP
  1354.         DW    QBRAN,DIGS2
  1355.         DW    BRAN,DIGS1
  1356. DIGS2:        DW    EXIT
  1357.  
  1358. ;   SIGN    ( n -- )
  1359. ;        Add a minus sign to the numeric output string.
  1360.  
  1361.         $COLON    4,'SIGN',SIGN
  1362.         DW    ZLESS
  1363.         DW    QBRAN,SIGN1
  1364.         DW    DOLIT,'-',HOLD
  1365. SIGN1:        DW    EXIT
  1366.  
  1367. ;   #>        ( w -- b u )
  1368. ;        Prepare the output string to be TYPE'd.
  1369.  
  1370.         $COLON    2,'#>',EDIGS
  1371.         DW    DROP,HLD,AT
  1372.         DW    PAD,OVER,SUBB,EXIT
  1373.  
  1374. ;   str        ( n -- b u )
  1375. ;        Convert a signed integer to a numeric string.
  1376.  
  1377.         $COLON    3,'str',STR
  1378.         DW    DUPP,TOR,ABSS
  1379.         DW    BDIGS,DIGS,RFROM
  1380.         DW    SIGN,EDIGS,EXIT
  1381.  
  1382. ;   HEX        ( -- )
  1383. ;        Use radix 16 as base for numeric conversions.
  1384.  
  1385.         $COLON    3,'HEX',HEX
  1386.         DW    DOLIT,16,BASE,STORE,EXIT
  1387.  
  1388. ;   DECIMAL    ( -- )
  1389. ;        Use radix 10 as base for numeric conversions.
  1390.  
  1391.         $COLON    7,'DECIMAL',DECIM
  1392.         DW    DOLIT,10,BASE,STORE,EXIT
  1393.  
  1394. ;; Numeric input, single precision
  1395.  
  1396. ;   DIGIT?    ( c base -- u t )
  1397. ;        Convert a character to its numeric value. A flag indicates success.
  1398.  
  1399.         $COLON    6,'DIGIT?',DIGTQ
  1400.         DW    TOR,DOLIT,'0',SUBB
  1401.         DW    DOLIT,9,OVER,LESS
  1402.         DW    QBRAN,DGTQ1
  1403.         DW    DOLIT,7,SUBB
  1404.         DW    DUPP,DOLIT,10,LESS,ORR
  1405. DGTQ1:        DW    DUPP,RFROM,ULESS,EXIT
  1406.  
  1407. ;   NUMBER?    ( a -- n T | a F )
  1408. ;        Convert a number string to integer. Push a flag on tos.
  1409.  
  1410.         $COLON    7,'NUMBER?',NUMBQ
  1411.         DW    BASE,AT,TOR,DOLIT,0,OVER,COUNT
  1412.         DW    OVER,CAT,DOLIT,'$',EQUAL
  1413.         DW    QBRAN,NUMQ1
  1414.         DW    HEX,SWAP,DOLIT,1,PLUS
  1415.         DW    SWAP,DOLIT,1,SUBB
  1416. NUMQ1:        DW    OVER,CAT,DOLIT,'-',EQUAL,TOR
  1417.         DW    SWAP,RAT,SUBB,SWAP,RAT,PLUS,QDUP
  1418.         DW    QBRAN,NUMQ6
  1419.         DW    DOLIT,1,SUBB,TOR
  1420. NUMQ2:        DW    DUPP,TOR,CAT,BASE,AT,DIGTQ
  1421.         DW    QBRAN,NUMQ4
  1422.         DW    SWAP,BASE,AT,STAR,PLUS,RFROM
  1423.         DW    DOLIT,1,PLUS
  1424.         DW    DONXT,NUMQ2
  1425.         DW    RAT,SWAP,DROP
  1426.         DW    QBRAN,NUMQ3
  1427.         DW    NEGAT
  1428. NUMQ3:        DW    SWAP
  1429.         DW    BRAN,NUMQ5
  1430. NUMQ4:        DW    RFROM,RFROM,DDROP,DDROP,DOLIT,0
  1431. NUMQ5:        DW    DUPP
  1432. NUMQ6:        DW    RFROM,DDROP
  1433.         DW    RFROM,BASE,STORE,EXIT
  1434.  
  1435. ;; Basic I/O
  1436.  
  1437. ;   ?KEY    ( -- c T | F )
  1438. ;        Return input character and true, or a false if no input.
  1439.  
  1440.         $COLON    4,'?KEY',QKEY
  1441.         DW    TQKEY,ATEXE,EXIT
  1442.  
  1443. ;   KEY        ( -- c )
  1444. ;        Wait for and return an input character.
  1445.  
  1446.         $COLON    3,'KEY',KEY
  1447. KEY1:        DW    QKEY
  1448.         DW    QBRAN,KEY1
  1449.         DW    EXIT
  1450.  
  1451. ;   EMIT    ( c -- )
  1452. ;        Send a character to the output device.
  1453.  
  1454.         $COLON    4,'EMIT',EMIT
  1455.         DW    TEMIT,ATEXE,EXIT
  1456.  
  1457. ;   NUF?    ( -- t )
  1458. ;        Return false if no input, else pause and if CR return true.
  1459.  
  1460.         $COLON    4,'NUF?',NUFQ
  1461.         DW    QKEY,DUPP
  1462.         DW    QBRAN,NUFQ1
  1463.         DW    DDROP,KEY,DOLIT,CRR,EQUAL
  1464. NUFQ1:        DW    EXIT
  1465.  
  1466. ;   PACE    ( -- )
  1467. ;        Send a pace character for the file downloading process.
  1468.  
  1469.         $COLON    4,'PACE',PACE
  1470.         DW    DOLIT,11,EMIT,EXIT
  1471.  
  1472. ;   SPACE    ( -- )
  1473. ;        Send the blank character to the output device.
  1474.  
  1475.         $COLON    5,'SPACE',SPACE
  1476.         DW    BLANK,EMIT,EXIT
  1477.  
  1478. ;   SPACES    ( +n -- )
  1479. ;        Send n spaces to the output device.
  1480.  
  1481.         $COLON    6,'SPACES',SPACS
  1482.         DW    DOLIT,0,MAX,TOR
  1483.         DW    BRAN,CHAR2
  1484. CHAR1:        DW    SPACE
  1485. CHAR2:        DW    DONXT,CHAR1
  1486.         DW    EXIT
  1487.  
  1488. ;   TYPE    ( b u -- )
  1489. ;        Output u characters from b.
  1490.  
  1491.         $COLON    4,'TYPE',TYPEE
  1492.         DW    TOR
  1493.         DW    BRAN,TYPE2
  1494. TYPE1:        DW    DUPP,CAT,EMIT
  1495.         DW    DOLIT,1,PLUS
  1496. TYPE2:        DW    DONXT,TYPE1
  1497.         DW    DROP,EXIT
  1498.  
  1499. ;   CR        ( -- )
  1500. ;        Output a carriage return and a line feed.
  1501.  
  1502.         $COLON    2,'CR',CR
  1503.         DW    DOLIT,CRR,EMIT
  1504.         DW    DOLIT,LF,EMIT,EXIT
  1505.  
  1506. ;   do$        ( -- a )
  1507. ;        Return the address of a compiled string.
  1508.  
  1509.         $COLON    COMPO+3,'do$',DOSTR
  1510.         DW    RFROM,RAT,RFROM,COUNT,PLUS
  1511.         DW    ALGND,TOR,SWAP,TOR,EXIT
  1512.  
  1513. ;   $"|        ( -- a )
  1514. ;        Run time routine compiled by $". Return address of a compiled string.
  1515.  
  1516.         $COLON    COMPO+3,'$"|',STRQP
  1517.         DW    DOSTR,EXIT        ;force a call to do$
  1518.  
  1519. ;   ."|        ( -- )
  1520. ;        Run time routine of ." . Output a compiled string.
  1521.  
  1522.         $COLON    COMPO+3,'."|',DOTQP
  1523.         DW    DOSTR,COUNT,TYPEE,EXIT
  1524.  
  1525. ;   .R        ( n +n -- )
  1526. ;        Display an integer in a field of n columns, right justified.
  1527.  
  1528.         $COLON    2,'.R',DOTR
  1529.         DW    TOR,STR,RFROM,OVER,SUBB
  1530.         DW    SPACS,TYPEE,EXIT
  1531.  
  1532. ;   U.R        ( u +n -- )
  1533. ;        Display an unsigned integer in n column, right justified.
  1534.  
  1535.         $COLON    3,'U.R',UDOTR
  1536.         DW    TOR,BDIGS,DIGS,EDIGS
  1537.         DW    RFROM,OVER,SUBB
  1538.         DW    SPACS,TYPEE,EXIT
  1539.  
  1540. ;   U.        ( u -- )
  1541. ;        Display an unsigned integer in free format.
  1542.  
  1543.         $COLON    2,'U.',UDOT
  1544.         DW    BDIGS,DIGS,EDIGS
  1545.         DW    SPACE,TYPEE,EXIT
  1546.  
  1547. ;   .        ( w -- )
  1548. ;        Display an integer in free format, preceeded by a space.
  1549.  
  1550.         $COLON    1,'.',DOT
  1551.         DW    BASE,AT,DOLIT,10,XORR    ;?decimal
  1552.         DW    QBRAN,DOT1
  1553.         DW    UDOT,EXIT        ;no, display unsigned
  1554. DOT1:        DW    STR,SPACE,TYPEE,EXIT    ;yes, display signed
  1555.  
  1556. ;   ?        ( a -- )
  1557. ;        Display the contents in a memory cell.
  1558.  
  1559.         $COLON    1,'?',QUEST
  1560.         DW    AT,DOT,EXIT
  1561.  
  1562. ;; Parsing
  1563.  
  1564. ;   parse    ( b u c -- b u delta ; <string> )
  1565. ;        Scan string delimited by c. Return found string and its offset.
  1566.  
  1567.         $COLON    5,'parse',PARS
  1568.         DW    TEMP,STORE,OVER,TOR,DUPP
  1569.         DW    QBRAN,PARS8
  1570.         DW    DOLIT,1,SUBB,TEMP,AT,BLANK,EQUAL
  1571.         DW    QBRAN,PARS3
  1572.         DW    TOR
  1573. PARS1:        DW    BLANK,OVER,CAT        ;skip leading blanks ONLY
  1574.         DW    SUBB,ZLESS,INVER
  1575.         DW    QBRAN,PARS2
  1576.         DW    DOLIT,1,PLUS
  1577.         DW    DONXT,PARS1
  1578.         DW    RFROM,DROP,DOLIT,0,DUPP,EXIT
  1579. PARS2:        DW    RFROM
  1580. PARS3:        DW    OVER,SWAP
  1581.         DW    TOR
  1582. PARS4:        DW    TEMP,AT,OVER,CAT,SUBB    ;scan for delimiter
  1583.         DW    TEMP,AT,BLANK,EQUAL
  1584.         DW    QBRAN,PARS5
  1585.         DW    ZLESS
  1586. PARS5:        DW    QBRAN,PARS6
  1587.         DW    DOLIT,1,PLUS
  1588.         DW    DONXT,PARS4
  1589.         DW    DUPP,TOR
  1590.         DW    BRAN,PARS7
  1591. PARS6:        DW    RFROM,DROP,DUPP
  1592.         DW    DOLIT,1,PLUS,TOR
  1593. PARS7:        DW    OVER,SUBB
  1594.         DW    RFROM,RFROM,SUBB,EXIT
  1595. PARS8:        DW    OVER,RFROM,SUBB,EXIT
  1596.  
  1597. ;   PARSE    ( c -- b u ; <string> )
  1598. ;        Scan input stream and return counted string delimited by c.
  1599.  
  1600.         $COLON    5,'PARSE',PARSE
  1601.         DW    TOR,TIB,INN,AT,PLUS    ;current input buffer pointer
  1602.         DW    NTIB,AT,INN,AT,SUBB    ;remaining count
  1603.         DW    RFROM,PARS,INN,PSTOR,EXIT
  1604.  
  1605. ;   .(        ( -- )
  1606. ;        Output following string up to next ) .
  1607.  
  1608.         $COLON    IMEDD+2,'.(',DOTPR
  1609.         DW    DOLIT,')',PARSE,TYPEE,EXIT
  1610.  
  1611. ;   (        ( -- )
  1612. ;        Ignore following string up to next ) . A comment.
  1613.  
  1614.         $COLON    IMEDD+1,'(',PAREN
  1615.         DW    DOLIT,')',PARSE,DDROP,EXIT
  1616.  
  1617. ;   \        ( -- )
  1618. ;        Ignore following text till the end of line.
  1619.  
  1620.         $COLON    IMEDD+1,'\',BKSLA
  1621.         DW    NTIB,AT,INN,STORE,EXIT
  1622.  
  1623. ;   CHAR    ( -- c )
  1624. ;        Parse next word and return its first character.
  1625.  
  1626.         $COLON    4,'CHAR',CHAR
  1627.         DW    BLANK,PARSE,DROP,CAT,EXIT
  1628.  
  1629. ;   TOKEN    ( -- a ; <string> )
  1630. ;        Parse a word from input stream and copy it to name dictionary.
  1631.  
  1632.         $COLON    5,'TOKEN',TOKEN
  1633.         DW    BLANK,PARSE,DOLIT,31,MIN
  1634.         DW    NP,AT,OVER,SUBB,CELLM
  1635.         DW    PACKS,EXIT
  1636.  
  1637. ;   WORD    ( c -- a ; <string> )
  1638. ;        Parse a word from input stream and copy it to code dictionary.
  1639.  
  1640.         $COLON    4,'WORD',WORDD
  1641.         DW    PARSE,HERE,PACKS,EXIT
  1642.  
  1643. ;; Dictionary search
  1644.  
  1645. ;   NAME>    ( na -- ca )
  1646. ;        Return a code address given a name address.
  1647.  
  1648.         $COLON    5,'NAME>',NAMET
  1649.         DW    CELLM,CELLM,AT,EXIT
  1650.  
  1651. ;   SAME?    ( a a u -- a a f \ -0+ )
  1652. ;        Compare u cells in two strings. Return 0 if identical.
  1653.  
  1654.         $COLON    5,'SAME?',SAMEQ
  1655.         DW    TOR
  1656.         DW    BRAN,SAME2
  1657. SAME1:        DW    OVER,RAT,CELLS,PLUS,AT
  1658.         DW    OVER,RAT,CELLS,PLUS,AT
  1659.         DW    SUBB,QDUP
  1660.         DW    QBRAN,SAME2
  1661.         DW    RFROM,DROP,EXIT        ;strings not equal
  1662. SAME2:        DW    DONXT,SAME1
  1663.         DW    DOLIT,0,EXIT        ;strings equal
  1664.  
  1665. ;   find    ( a va -- ca na | a F )
  1666. ;        Search a vocabulary for a string. Return ca and na if succeeded.
  1667.  
  1668.         $COLON    4,'find',FIND
  1669.         DW    SWAP,DUPP,CAT
  1670.         DW    DOLIT,CELLL,SLASH,TEMP,STORE
  1671.         DW    DUPP,AT,TOR,CELLP,SWAP
  1672. FIND1:        DW    AT,DUPP
  1673.         DW    QBRAN,FIND6
  1674.         DW    DUPP,AT,DOLIT,MASKK,ANDD,RAT,XORR
  1675.         DW    QBRAN,FIND2
  1676.         DW    CELLP,DOLIT,-1        ;true flag
  1677.         DW    BRAN,FIND3
  1678. FIND2:        DW    CELLP,TEMP,AT,SAMEQ
  1679. FIND3:        DW    BRAN,FIND4
  1680. FIND6:        DW    RFROM,DROP
  1681.         DW    SWAP,CELLM,SWAP,EXIT
  1682. FIND4:        DW    QBRAN,FIND5
  1683.         DW    CELLM,CELLM
  1684.         DW    BRAN,FIND1
  1685. FIND5:        DW    RFROM,DROP,SWAP,DROP
  1686.         DW    CELLM
  1687.         DW    DUPP,NAMET,SWAP,EXIT
  1688.  
  1689. ;   NAME?    ( a -- ca na | a F )
  1690. ;        Search all context vocabularies for a string.
  1691.  
  1692.         $COLON    5,'NAME?',NAMEQ
  1693.         DW    CNTXT,DUPP,DAT,XORR    ;?context=also
  1694.         DW    QBRAN,NAMQ1
  1695.         DW    CELLM            ;no, start with context
  1696. NAMQ1:        DW    TOR
  1697. NAMQ2:        DW    RFROM,CELLP,DUPP,TOR    ;next in search order
  1698.         DW    AT,QDUP
  1699.         DW    QBRAN,NAMQ3
  1700.         DW    FIND,QDUP        ;search vocabulary
  1701.         DW    QBRAN,NAMQ2
  1702.         DW    RFROM,DROP,EXIT        ;found name
  1703. NAMQ3:        DW    RFROM,DROP        ;name not found
  1704.         DW    DOLIT,0,EXIT        ;false flag
  1705.  
  1706. ;; Terminal response
  1707.  
  1708. ;   ^H        ( bot eot cur -- bot eot cur )
  1709. ;        Backup the cursor by one character.
  1710.  
  1711.         $COLON    2,'^H',BKSP
  1712.         DW    TOR,OVER,RFROM,SWAP,OVER,XORR
  1713.         DW    QBRAN,BACK1
  1714.         DW    DOLIT,BKSPP,TECHO,ATEXE,DOLIT,1,SUBB
  1715.         DW    BLANK,TECHO,ATEXE
  1716.         DW    DOLIT,BKSPP,TECHO,ATEXE
  1717. BACK1:        DW    EXIT
  1718.  
  1719. ;   TAP        ( bot eot cur c -- bot eot cur )
  1720. ;        Accept and echo the key stroke and bump the cursor.
  1721.  
  1722.         $COLON    3,'TAP',TAP
  1723.         DW    DUPP,TECHO,ATEXE
  1724.         DW    OVER,CSTOR,DOLIT,1,PLUS,EXIT
  1725.  
  1726. ;   kTAP    ( bot eot cur c -- bot eot cur )
  1727. ;        Process a key stroke, CR or backspace.
  1728.  
  1729.         $COLON    4,'kTAP',KTAP
  1730.         DW    DUPP,DOLIT,CRR,XORR
  1731.         DW    QBRAN,KTAP2
  1732.         DW    DOLIT,BKSPP,XORR
  1733.         DW    QBRAN,KTAP1
  1734.         DW    BLANK,TAP,EXIT
  1735. KTAP1:        DW    BKSP,EXIT
  1736. KTAP2:        DW    DROP,SWAP,DROP,DUPP,EXIT
  1737.  
  1738. ;   accept    ( b u -- b u )
  1739. ;        Accept characters to input buffer. Return with actual count.
  1740.  
  1741.         $COLON    6,'accept',ACCEP
  1742.         DW    OVER,PLUS,OVER
  1743. ACCP1:        DW    DDUP,XORR
  1744.         DW    QBRAN,ACCP4
  1745.         DW    KEY,DUPP
  1746. ;        DW    BLANK,SUBB,DOLIT,95,ULESS
  1747.         DW    BLANK,DOLIT,127,WITHI
  1748.         DW    QBRAN,ACCP2
  1749.         DW    TAP
  1750.         DW    BRAN,ACCP3
  1751. ACCP2:        DW    TTAP,ATEXE
  1752. ACCP3:        DW    BRAN,ACCP1
  1753. ACCP4:        DW    DROP,OVER,SUBB,EXIT
  1754.  
  1755. ;   EXPECT    ( b u -- )
  1756. ;        Accept input stream and store count in SPAN.
  1757.  
  1758.         $COLON    6,'EXPECT',EXPEC
  1759.         DW    TEXPE,ATEXE,SPAN,STORE,DROP,EXIT
  1760.  
  1761. ;   QUERY    ( -- )
  1762. ;        Accept input stream to terminal input buffer.
  1763.  
  1764.         $COLON    5,'QUERY',QUERY
  1765.         DW    TIB,DOLIT,80,TEXPE,ATEXE,NTIB,STORE
  1766.         DW    DROP,DOLIT,0,INN,STORE,EXIT
  1767.  
  1768. ;; Error handling
  1769.  
  1770. ;   CATCH    ( ca -- 0 | err# )
  1771. ;        Execute word at ca and set up an error frame for it.
  1772.  
  1773.         $COLON    5,'CATCH',CATCH
  1774.         DW    SPAT,TOR,HANDL,AT,TOR    ;save error frame
  1775.         DW    RPAT,HANDL,STORE,EXECU    ;execute
  1776.         DW    RFROM,HANDL,STORE    ;restore error frame
  1777.         DW    RFROM,DROP,DOLIT,0,EXIT    ;no error
  1778.  
  1779. ;   THROW    ( err# -- err# )
  1780. ;        Reset system to current local error frame an update error flag.
  1781.  
  1782.         $COLON    5,'THROW',THROW
  1783.         DW    HANDL,AT,RPSTO        ;restore return stack
  1784.         DW    RFROM,HANDL,STORE    ;restore handler frame
  1785.         DW    RFROM,SWAP,TOR,SPSTO    ;restore data stack
  1786.         DW    DROP,RFROM,EXIT
  1787.  
  1788. ;   NULL$    ( -- a )
  1789. ;        Return address of a null string with zero count.
  1790.  
  1791.         $COLON    5,'NULL$',NULLS
  1792.         DW    DOVAR            ;emulate CREATE
  1793.         DW    0
  1794.         DB    99,111,121,111,116,101
  1795.         $ALIGN
  1796.  
  1797. ;   ABORT    ( -- )
  1798. ;        Reset data stack and jump to QUIT.
  1799.  
  1800.         $COLON    5,'ABORT',ABORT
  1801.         DW    NULLS,THROW
  1802.  
  1803. ;   abort"    ( f -- )
  1804. ;        Run time routine of ABORT" . Abort with a message.
  1805.  
  1806.         $COLON    COMPO+6,'abort"',ABORQ
  1807.         DW    QBRAN,ABOR1        ;text flag
  1808.         DW    DOSTR,THROW        ;pass error string
  1809. ABOR1:        DW    DOSTR,DROP,EXIT        ;drop error
  1810.  
  1811. ;; The text interpreter
  1812.  
  1813. ;   $INTERPRET    ( a -- )
  1814. ;        Interpret a word. If failed, try to convert it to an integer.
  1815.  
  1816.         $COLON    10,'$INTERPRET',INTER
  1817.         DW    NAMEQ,QDUP        ;?defined
  1818.         DW    QBRAN,INTE1
  1819.         DW    AT,DOLIT,COMPO,ANDD    ;?compile only lexicon bits
  1820.         D$    ABORQ,' compile only'
  1821.         DW    EXECU,EXIT        ;execute defined word
  1822. INTE1:        DW    TNUMB,ATEXE        ;convert a number
  1823.         DW    QBRAN,INTE2
  1824.         DW    EXIT
  1825. INTE2:        DW    THROW            ;error
  1826.  
  1827. ;   [        ( -- )
  1828. ;        Start the text interpreter.
  1829.  
  1830.         $COLON    IMEDD+1,'[',LBRAC
  1831.         DW    DOLIT,INTER,TEVAL,STORE,EXIT
  1832.  
  1833. ;   .OK        ( -- )
  1834. ;        Display 'ok' only while interpreting.
  1835.  
  1836.         $COLON    3,'.OK',DOTOK
  1837.         DW    DOLIT,INTER,TEVAL,AT,EQUAL
  1838.         DW    QBRAN,DOTO1
  1839.         D$    DOTQP,' ok'
  1840. DOTO1:        DW    CR,EXIT
  1841.  
  1842. ;   ?STACK    ( -- )
  1843. ;        Abort if the data stack underflows.
  1844.  
  1845.         $COLON    6,'?STACK',QSTAC
  1846.         DW    DEPTH,ZLESS        ;check only for underflow
  1847.         D$    ABORQ,' underflow'
  1848.         DW    EXIT
  1849.  
  1850. ;   EVAL    ( -- )
  1851. ;        Interpret the input stream.
  1852.  
  1853.         $COLON    4,'EVAL',EVAL
  1854. EVAL1:        DW    TOKEN,DUPP,CAT        ;?input stream empty
  1855.         DW    QBRAN,EVAL2
  1856.         DW    TEVAL,ATEXE,QSTAC    ;evaluate input, check stack
  1857.         DW    BRAN,EVAL1
  1858. EVAL2:        DW    DROP,TPROM,ATEXE,EXIT    ;prompt
  1859.  
  1860. ;; Shell
  1861.  
  1862. ;   PRESET    ( -- )
  1863. ;        Reset data stack pointer and the terminal input buffer.
  1864.  
  1865.         $COLON    6,'PRESET',PRESE
  1866.         DW    SZERO,AT,SPSTO
  1867.         DW    DOLIT,TIBB,NTIB,CELLP,STORE,EXIT
  1868.  
  1869. ;   xio        ( a a a -- )
  1870. ;        Reset the I/O vectors 'EXPECT, 'TAP, 'ECHO and 'PROMPT.
  1871.  
  1872.         $COLON    COMPO+3,'xio',XIO
  1873.         DW    DOLIT,ACCEP,TEXPE,DSTOR
  1874.         DW    TECHO,DSTOR,EXIT
  1875.  
  1876. ;   FILE    ( -- )
  1877. ;        Select I/O vectors for file download.
  1878.  
  1879.         $COLON    4,'FILE',FILE
  1880.         DW    DOLIT,PACE,DOLIT,DROP
  1881.         DW    DOLIT,KTAP,XIO,EXIT
  1882.  
  1883. ;   HAND    ( -- )
  1884. ;        Select I/O vectors for terminal interface.
  1885.  
  1886.         $COLON    4,'HAND',HAND
  1887.         DW    DOLIT,DOTOK,DOLIT,EMIT
  1888.         DW    DOLIT,KTAP,XIO,EXIT
  1889.  
  1890. ;   I/O        ( -- a )
  1891. ;        Array to store default I/O vectors.
  1892.  
  1893.         $COLON    3,'I/O',ISLO
  1894.         DW    DOVAR            ;emulate CREATE
  1895.         DW    QRX,TXSTO        ;default I/O vectors
  1896.  
  1897. ;   CONSOLE    ( -- )
  1898. ;        Initiate terminal interface.
  1899.  
  1900.         $COLON    7,'CONSOLE',CONSO
  1901.         DW    ISLO,DAT,TQKEY,DSTOR    ;restore default I/O device
  1902.         DW    HAND,EXIT        ;keyboard input
  1903.  
  1904. ;   QUIT    ( -- )
  1905. ;        Reset return stack pointer and start text interpreter.
  1906.  
  1907.         $COLON    4,'QUIT',QUIT
  1908.         DW    RZERO,AT,RPSTO        ;reset return stack pointer
  1909. QUIT1:        DW    LBRAC            ;start interpretation
  1910. QUIT2:        DW    QUERY            ;get input
  1911.         DW    DOLIT,EVAL,CATCH,QDUP    ;evaluate input
  1912.         DW    QBRAN,QUIT2        ;continue till error
  1913.         DW    TPROM,AT,SWAP        ;save input device
  1914.         DW    CONSO,NULLS,OVER,XORR    ;?display error message
  1915.         DW    QBRAN,QUIT3
  1916.         DW    SPACE,COUNT,TYPEE    ;error message
  1917.         D$    DOTQP,' ? '        ;error prompt
  1918. QUIT3:        DW    DOLIT,DOTOK,XORR    ;?file input
  1919.         DW    QBRAN,QUIT4
  1920.         DW    DOLIT,ERR,EMIT        ;file error, tell host
  1921. QUIT4:        DW    PRESE            ;some cleanup
  1922.         DW    BRAN,QUIT1
  1923.  
  1924. ;; The compiler
  1925.  
  1926. ;   '        ( -- ca )
  1927. ;        Search context vocabularies for the next word in input stream.
  1928.  
  1929.         $COLON    1,"'",TICK
  1930.         DW    TOKEN,NAMEQ        ;?defined
  1931.         DW    QBRAN,TICK1
  1932.         DW    EXIT            ;yes, push code address
  1933. TICK1:        DW    THROW            ;no, error
  1934.  
  1935. ;   ALLOT    ( n -- )
  1936. ;        Allocate n bytes to the code dictionary.
  1937.  
  1938.         $COLON    5,'ALLOT',ALLOT
  1939.         DW    CP,PSTOR,EXIT        ;adjust code pointer
  1940.  
  1941. ;   ,        ( w -- )
  1942. ;        Compile an integer into the code dictionary.
  1943.  
  1944.         $COLON    1,',',COMMA
  1945.         DW    HERE,DUPP,CELLP        ;cell boundary
  1946.         DW    CP,STORE,STORE,EXIT    ;adjust code pointer, compile
  1947.  
  1948. ;   [COMPILE]    ( -- ; <string> )
  1949. ;        Compile the next immediate word into code dictionary.
  1950.  
  1951.         $COLON    IMEDD+9,'[COMPILE]',BCOMP
  1952.         DW    TICK,COMMA,EXIT
  1953.  
  1954. ;   COMPILE    ( -- )
  1955. ;        Compile the next address in colon list to code dictionary.
  1956.  
  1957.         $COLON    COMPO+7,'COMPILE',COMPI
  1958.         DW    RFROM,DUPP,AT,COMMA    ;compile address
  1959.         DW    CELLP,TOR,EXIT        ;adjust return address
  1960.  
  1961. ;   LITERAL    ( w -- )
  1962. ;        Compile tos to code dictionary as an integer literal.
  1963.  
  1964.         $COLON    IMEDD+7,'LITERAL',LITER
  1965.         DW    COMPI,DOLIT,COMMA,EXIT
  1966.  
  1967. ;   $,"        ( -- )
  1968. ;        Compile a literal string up to next " .
  1969.  
  1970.         $COLON    3,'$,"',STRCQ
  1971.         DW    DOLIT,'"',WORDD        ;move string to code dictionary
  1972.         DW    COUNT,PLUS,ALGND    ;calculate aligned end of string
  1973.         DW    CP,STORE,EXIT        ;adjust the code pointer
  1974.  
  1975. ;   RECURSE    ( -- )
  1976. ;        Make the current word available for compilation.
  1977.  
  1978.         $COLON    IMEDD+7,'RECURSE',RECUR
  1979.         DW    LAST,AT,NAMET,COMMA,EXIT
  1980.  
  1981. ;; Structures
  1982.  
  1983. ;   FOR        ( -- a )
  1984. ;        Start a FOR-NEXT loop structure in a colon definition.
  1985.  
  1986.         $COLON    IMEDD+3,'FOR',FOR
  1987.         DW    COMPI,TOR,HERE,EXIT
  1988.  
  1989. ;   BEGIN    ( -- a )
  1990. ;        Start an infinite or indefinite loop structure.
  1991.  
  1992.         $COLON    IMEDD+5,'BEGIN',BEGIN
  1993.         DW    HERE,EXIT
  1994.  
  1995. ;   NEXT    ( a -- )
  1996. ;        Terminate a FOR-NEXT loop structure.
  1997.  
  1998.         $COLON    IMEDD+4,'NEXT',NEXT
  1999.         DW    COMPI,DONXT,COMMA,EXIT
  2000.  
  2001. ;   UNTIL    ( a -- )
  2002. ;        Terminate a BEGIN-UNTIL indefinite loop structure.
  2003.  
  2004.         $COLON    IMEDD+5,'UNTIL',UNTIL
  2005.         DW    COMPI,QBRAN,COMMA,EXIT
  2006.  
  2007. ;   AGAIN    ( a -- )
  2008. ;        Terminate a BEGIN-AGAIN infinite loop structure.
  2009.  
  2010.         $COLON    IMEDD+5,'AGAIN',AGAIN
  2011.         DW    COMPI,BRAN,COMMA,EXIT
  2012.  
  2013. ;   IF        ( -- A )
  2014. ;        Begin a conditional branch structure.
  2015.  
  2016.         $COLON    IMEDD+2,'IF',IFF
  2017.         DW    COMPI,QBRAN,HERE
  2018.         DW    DOLIT,0,COMMA,EXIT
  2019.  
  2020. ;   AHEAD    ( -- A )
  2021. ;        Compile a forward branch instruction.
  2022.  
  2023.         $COLON    IMEDD+5,'AHEAD',AHEAD
  2024.         DW    COMPI,BRAN,HERE,DOLIT,0,COMMA,EXIT
  2025.  
  2026. ;   REPEAT    ( A a -- )
  2027. ;        Terminate a BEGIN-WHILE-REPEAT indefinite loop.
  2028.  
  2029.         $COLON    IMEDD+6,'REPEAT',REPEA
  2030.         DW    AGAIN,HERE,SWAP,STORE,EXIT
  2031.  
  2032. ;   THEN    ( A -- )
  2033. ;        Terminate a conditional branch structure.
  2034.  
  2035.         $COLON    IMEDD+4,'THEN',THENN
  2036.         DW    HERE,SWAP,STORE,EXIT
  2037.  
  2038. ;   AFT        ( a -- a A )
  2039. ;        Jump to THEN in a FOR-AFT-THEN-NEXT loop the first time through.
  2040.  
  2041.         $COLON    IMEDD+3,'AFT',AFT
  2042.         DW    DROP,AHEAD,BEGIN,SWAP,EXIT
  2043.  
  2044. ;   ELSE    ( A -- A )
  2045. ;        Start the false clause in an IF-ELSE-THEN structure.
  2046.  
  2047.         $COLON    IMEDD+4,'ELSE',ELSEE
  2048.         DW    AHEAD,SWAP,THENN,EXIT
  2049.  
  2050. ;   WHILE    ( a -- A a )
  2051. ;        Conditional branch out of a BEGIN-WHILE-REPEAT loop.
  2052.  
  2053.         $COLON    IMEDD+5,'WHILE',WHILE
  2054.         DW    IFF,SWAP,EXIT
  2055.  
  2056. ;   ABORT"    ( -- ; <string> )
  2057. ;        Conditional abort with an error message.
  2058.  
  2059.         $COLON    IMEDD+6,'ABORT"',ABRTQ
  2060.         DW    COMPI,ABORQ,STRCQ,EXIT
  2061.  
  2062. ;   $"        ( -- ; <string> )
  2063. ;        Compile an inline string literal.
  2064.  
  2065.         $COLON    IMEDD+2,'$"',STRQ
  2066.         DW    COMPI,STRQP,STRCQ,EXIT
  2067.  
  2068. ;   ."        ( -- ; <string> )
  2069. ;        Compile an inline string literal to be typed out at run time.
  2070.  
  2071.         $COLON    IMEDD+2,'."',DOTQ
  2072.         DW    COMPI,DOTQP,STRCQ,EXIT
  2073.  
  2074. ;; Name compiler
  2075.  
  2076. ;   ?UNIQUE    ( a -- a )
  2077. ;        Display a warning message if the word already exists.
  2078.  
  2079.         $COLON    7,'?UNIQUE',UNIQU
  2080.         DW    DUPP,NAMEQ        ;?name exists
  2081.         DW    QBRAN,UNIQ1        ;redefinitions are OK
  2082.         D$    DOTQP,' reDef '        ;but warn the user
  2083.         DW    OVER,COUNT,TYPEE    ;just in case its not planned
  2084. UNIQ1:        DW    DROP,EXIT
  2085.  
  2086. ;   $,n        ( na -- )
  2087. ;        Build a new dictionary name using the string at na.
  2088.  
  2089.         $COLON    3,'$,n',SNAME
  2090.         DW    DUPP,CAT        ;?null input
  2091.         DW    QBRAN,PNAM1
  2092.         DW    UNIQU            ;?redefinition
  2093.         DW    DUPP,LAST,STORE        ;save na for vocabulary link
  2094.         DW    HERE,ALGND,SWAP        ;align code address
  2095.         DW    CELLM            ;link address
  2096.         DW    CRRNT,AT,AT,OVER,STORE
  2097.         DW    CELLM,DUPP,NP,STORE    ;adjust name pointer
  2098.         DW    STORE,EXIT        ;save code pointer
  2099. PNAM1:        D$    STRQP,' name'        ;null input
  2100.         DW    THROW
  2101.  
  2102. ;; FORTH compiler
  2103.  
  2104. ;   $COMPILE    ( a -- )
  2105. ;        Compile next word to code dictionary as a token or literal.
  2106.  
  2107.         $COLON    8,'$COMPILE',SCOMP
  2108.         DW    NAMEQ,QDUP        ;?defined
  2109.         DW    QBRAN,SCOM2
  2110.         DW    AT,DOLIT,IMEDD,ANDD    ;?immediate
  2111.         DW    QBRAN,SCOM1
  2112.         DW    EXECU,EXIT        ;its immediate, execute
  2113. SCOM1:        DW    COMMA,EXIT        ;its not immediate, compile
  2114. SCOM2:        DW    TNUMB,ATEXE        ;try to convert to number
  2115.         DW    QBRAN,SCOM3
  2116.         DW    LITER,EXIT        ;compile number as integer
  2117. SCOM3:        DW    THROW            ;error
  2118.  
  2119. ;   OVERT    ( -- )
  2120. ;        Link a new word into the current vocabulary.
  2121.  
  2122.         $COLON    5,'OVERT',OVERT
  2123.         DW    LAST,AT,CRRNT,AT,STORE,EXIT
  2124.  
  2125. ;   ;        ( -- )
  2126. ;        Terminate a colon definition.
  2127.  
  2128.         $COLON    IMEDD+COMPO+1,';',SEMIS
  2129.         DW    COMPI,EXIT,LBRAC,OVERT,EXIT
  2130.  
  2131. ;   ]        ( -- )
  2132. ;        Start compiling the words in the input stream.
  2133.  
  2134.         $COLON    1,']',RBRAC
  2135.         DW    DOLIT,SCOMP,TEVAL,STORE,EXIT
  2136.  
  2137. ;   call,    ( ca -- )
  2138. ;        Assemble a call instruction to ca.
  2139.  
  2140.         $COLON    5,'call,',CALLC
  2141.         DW    DOLIT,CALLL,COMMA    ;Direct Threaded Code
  2142.         DW    COMMA,EXIT    ;DTC 8086 relative call
  2143.  
  2144. ;   :        ( -- ; <string> )
  2145. ;        Start a new colon definition using next word as its name.
  2146.  
  2147.         $COLON    1,':',COLON
  2148.         DW    TOKEN,SNAME,DOLIT,LISTT
  2149.         DW    CALLC,RBRAC,EXIT
  2150.  
  2151. ;   IMMEDIATE    ( -- )
  2152. ;        Make the last compiled word an immediate word.
  2153.  
  2154.         $COLON    9,'IMMEDIATE',IMMED
  2155.         DW    DOLIT,IMEDD,LAST,AT,AT,ORR
  2156.         DW    LAST,AT,STORE,EXIT
  2157.  
  2158. ;; Defining words
  2159.  
  2160. ;   USER    ( u -- ; <string> )
  2161. ;        Compile a new user variable.
  2162.  
  2163.         $COLON    4,'USER',USER
  2164.         DW    TOKEN,SNAME,OVERT
  2165.         DW    DOLIT,LISTT,CALLC
  2166.         DW    COMPI,DOUSE,COMMA,EXIT
  2167.  
  2168. ;   CREATE    ( -- ; <string> )
  2169. ;        Compile a new array entry without allocating code space.
  2170.  
  2171.         $COLON    6,'CREATE',CREAT
  2172.         DW    TOKEN,SNAME,OVERT
  2173.         DW    DOLIT,LISTT,CALLC
  2174.         DW    COMPI,DOVAR,EXIT
  2175.  
  2176. ;   VARIABLE    ( -- ; <string> )
  2177. ;        Compile a new variable initialized to 0.
  2178.  
  2179.         $COLON    8,'VARIABLE',VARIA
  2180.         DW    CREAT,DOLIT,0,COMMA,EXIT
  2181.  
  2182. ;; Tools
  2183.  
  2184. ;   _TYPE    ( b u -- )
  2185. ;        Display a string. Filter non-printing characters.
  2186.  
  2187.         $COLON    5,'_TYPE',UTYPE
  2188.         DW    TOR            ;start count down loop
  2189.         DW    BRAN,UTYP2        ;skip first pass
  2190. UTYP1:        DW    DUPP,CAT,TCHAR,EMIT    ;display only printable
  2191.         DW    DOLIT,1,PLUS        ;increment address
  2192. UTYP2:        DW    DONXT,UTYP1        ;loop till done
  2193.         DW    DROP,EXIT
  2194.  
  2195. ;   dm+        ( a u -- a )
  2196. ;        Dump u bytes from , leaving a+u on the stack.
  2197.  
  2198.         $COLON    3,'dm+',DMP
  2199.         DW    OVER,DOLIT,4,UDOTR    ;display address
  2200.         DW    SPACE,TOR        ;start count down loop
  2201.         DW    BRAN,PDUM2        ;skip first pass
  2202. PDUM1:        DW    DUPP,CAT,DOLIT,3,UDOTR    ;display numeric data
  2203.         DW    DOLIT,1,PLUS        ;increment address
  2204. PDUM2:        DW    DONXT,PDUM1        ;loop till done
  2205.         DW    EXIT
  2206.  
  2207. ;   DUMP    ( a u -- )
  2208. ;        Dump u bytes from a, in a formatted manner.
  2209.  
  2210.         $COLON    4,'DUMP',DUMP
  2211.         DW    BASE,AT,TOR,HEX        ;save radix, set hex
  2212.         DW    DOLIT,16,SLASH        ;change count to lines
  2213.         DW    TOR            ;start count down loop
  2214. DUMP1:        DW    CR,DOLIT,16,DDUP,DMP    ;display numeric
  2215.         DW    ROT,ROT
  2216.         DW    SPACE,SPACE,UTYPE    ;display printable characters
  2217.         DW    NUFQ,INVER        ;user control
  2218.         DW    QBRAN,DUMP2
  2219.         DW    DONXT,DUMP1        ;loop till done
  2220.         DW    BRAN,DUMP3
  2221. DUMP2:        DW    RFROM,DROP        ;cleanup loop stack, early exit
  2222. DUMP3:        DW    DROP,RFROM,BASE,STORE    ;restore radix
  2223.         DW    EXIT
  2224.  
  2225. ;   .S        ( ... -- ... )
  2226. ;        Display the contents of the data stack.
  2227.  
  2228.         $COLON    2,'.S',DOTS
  2229.         DW    CR,DEPTH        ;stack depth
  2230.         DW    TOR            ;start count down loop
  2231.         DW    BRAN,DOTS2        ;skip first pass
  2232. DOTS1:        DW    RAT,PICK,DOT        ;index stack, display contents
  2233. DOTS2:        DW    DONXT,DOTS1        ;loop till done
  2234.         D$    DOTQP,' <sp'
  2235.         DW    EXIT
  2236.  
  2237. ;   !CSP    ( -- )
  2238. ;        Save stack pointer in CSP for error checking.
  2239.  
  2240.         $COLON    4,'!CSP',STCSP
  2241.         DW    SPAT,CSP,STORE,EXIT    ;save pointer
  2242.  
  2243. ;   ?CSP    ( -- )
  2244. ;        Abort if stack pointer differs from that saved in CSP.
  2245.  
  2246.         $COLON    4,'?CSP',QCSP
  2247.         DW    SPAT,CSP,AT,XORR    ;compare pointers
  2248.         D$    ABORQ,'stacks'        ;abort if different
  2249.         DW    EXIT
  2250.  
  2251. ;   >NAME    ( ca -- na | F )
  2252. ;        Convert code address to a name address.
  2253.  
  2254.         $COLON    5,'>NAME',TNAME
  2255.         DW    CRRNT            ;vocabulary link
  2256. TNAM1:        DW    CELLP,AT,QDUP        ;check all vocabularies
  2257.         DW    QBRAN,TNAM4
  2258.         DW    DDUP
  2259. TNAM2:        DW    AT,DUPP            ;?last word in a vocabulary
  2260.         DW    QBRAN,TNAM3
  2261.         DW    DDUP,NAMET,XORR        ;compare
  2262.         DW    QBRAN,TNAM3
  2263.         DW    CELLM            ;continue with next word
  2264.         DW    BRAN,TNAM2
  2265. TNAM3:        DW    SWAP,DROP,QDUP
  2266.         DW    QBRAN,TNAM1
  2267.         DW    SWAP,DROP,SWAP,DROP,EXIT
  2268. TNAM4:        DW    DROP,DOLIT,0,EXIT    ;false flag
  2269.  
  2270. ;   .ID        ( na -- )
  2271. ;        Display the name at address.
  2272.  
  2273.         $COLON    3,'.ID',DOTID
  2274.         DW    QDUP            ;if zero no name
  2275.         DW    QBRAN,DOTI1
  2276.         DW    COUNT,DOLIT,01FH,ANDD    ;mask lexicon bits
  2277.         DW    UTYPE,EXIT        ;display name string
  2278. DOTI1:        D$    DOTQP,' {noName}'
  2279.         DW    EXIT
  2280.  
  2281. ;   SEE        ( -- ; <string> )
  2282. ;        A simple decompiler.
  2283.  
  2284.         $COLON    3,'SEE',SEE
  2285.         DW    TICK            ;starting address
  2286.         DW    CR,CELLP
  2287. SEE1:        DW    CELLP,DUPP,AT,DUPP    ;?does it contain a zero
  2288.         DW    QBRAN,SEE2
  2289.         DW    TNAME            ;?is it a name
  2290. SEE2:        DW    QDUP            ;name address or zero
  2291.         DW    QBRAN,SEE3
  2292.         DW    SPACE,DOTID        ;display name
  2293.         DW    BRAN,SEE4
  2294. SEE3:        DW    DUPP,AT,UDOT        ;display number
  2295. SEE4:        DW    NUFQ            ;user control
  2296.         DW    QBRAN,SEE1
  2297.         DW    DROP,EXIT
  2298.  
  2299. ;   WORDS    ( -- )
  2300. ;        Display the names in the context vocabulary.
  2301.  
  2302.         $COLON    5,'WORDS',WORDS
  2303.         DW    CR,CNTXT,AT        ;only in context
  2304. WORS1:        DW    AT,QDUP            ;?at end of list
  2305.         DW    QBRAN,WORS2
  2306.         DW    DUPP,SPACE,DOTID    ;display a name
  2307.         DW    CELLM,NUFQ        ;user control
  2308.         DW    QBRAN,WORS1
  2309.         DW    DROP
  2310. WORS2:        DW    EXIT
  2311.  
  2312. ;; Hardware reset
  2313.  
  2314. ;   VER        ( -- n )
  2315. ;        Return the version number of this implementation.
  2316.  
  2317.         $COLON    3,'VER',VERSN
  2318.         DW    DOLIT,VER*256+EXT,EXIT
  2319.  
  2320. ;   hi        ( -- )
  2321. ;        Display the sign-on message of eForth.
  2322.  
  2323.         $COLON    2,'hi',HI
  2324.         DW    STOIO,CR        ;initialize I/O
  2325.         D$    DOTQP,'eForth v'    ;model
  2326.         DW    BASE,AT,HEX        ;save radix
  2327.         DW    VERSN,BDIGS,DIG,DIG
  2328.         DW    DOLIT,'.',HOLD
  2329.         DW    DIGS,EDIGS,TYPEE    ;format version number
  2330.         DW    BASE,STORE,CR,EXIT    ;restore radix
  2331.  
  2332. ;   'BOOT    ( -- a )
  2333. ;        The application startup vector.
  2334.  
  2335.         $COLON    5,"'BOOT",TBOOT
  2336.         DW    DOVAR
  2337.         DW    HI            ;application to boot
  2338.  
  2339. ;   COLD    ( -- )
  2340. ;        The hilevel cold start sequence.
  2341.  
  2342.         $COLON    4,'COLD',COLD
  2343. COLD1:        DW    DOLIT,UZERO,DOLIT,UPP
  2344.         DW    DOLIT,ULAST-UZERO,CMOVE    ;initialize user area
  2345.         DW    PRESE            ;initialize stack and TIB
  2346.         DW    TBOOT,ATEXE        ;application boot
  2347.         DW    FORTH,CNTXT,AT,DUPP    ;initialize search order
  2348.         DW    CRRNT,DSTOR,OVERT
  2349.         DW    QUIT            ;start interpretation
  2350.         DW    BRAN,COLD1        ;just in case
  2351.  
  2352. ;===============================================================
  2353.  
  2354. LASTN        EQU    _NAME+4            ;last name address
  2355.  
  2356. NTOP        EQU    _NAME-0            ;next available memory in name dictionary
  2357. CTOP        EQU    $+0            ;next available memory in code dictionary
  2358.  
  2359. MAIN    ENDS
  2360. END    ORIG
  2361.  
  2362. ;===============================================================
  2363.  
  2364.